Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

finish!

  • Loading branch information...
commit deb70425c9d5cb88e7bf7fa8deea13ea9a6fbaa7 1 parent 4466af9
@accelas authored
Showing with 109 additions and 78 deletions.
  1. +1 −1  socks5.cabal
  2. +97 −23 src/Socks5/Internal.hs
  3. +11 −54 src/socks5.hs
View
2  socks5.cabal
@@ -25,7 +25,7 @@ Executable socks5
default-language: Haskell2010
ghc-options: -Wall -threaded
Build-depends:
- base ==4.5.*,
+ base >= 4.5 && < 4.7,
async,
binary,
bytestring (== 0.10.*),
View
120 src/Socks5/Internal.hs
@@ -4,9 +4,14 @@ import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
-import Data.ByteString as B (ByteString, length, pack)
-import Data.List as L (length)
-import Network.Socket
+import Data.ByteString as B (ByteString, length, pack)
+import Data.ByteString.Char8 as B (unpack)
+import Data.List as L (length)
+
+import Text.Printf
+
+import Control.Exception
+import qualified Network.Socket as NS
{--
+----+----------+----------+
@@ -18,12 +23,6 @@ import Network.Socket
newtype AuthMSG = AuthMSG (Word8, [Word8])
-authError :: AuthResp
-authError = AuthResp 255
-
-authSuccess :: AuthResp
-authSuccess = AuthResp 0
-
instance Binary AuthMSG where
get = do
_ <- sockVer
@@ -47,7 +46,7 @@ instance Binary AuthMSG where
putWord8 5
let num = fromIntegral $ L.length met
putWord8 num
- forM_ met $ putWord8
+ forM_ met putWord8
{--
@@ -58,8 +57,15 @@ instance Binary AuthMSG where
+----+--------+
--}
+
newtype AuthResp = AuthResp Word8
+authError :: AuthResp
+authError = AuthResp 255
+
+authSuccess :: AuthResp
+authSuccess = AuthResp 0
+
instance Binary AuthResp where
get = do
_ <- sockVer
@@ -101,34 +107,39 @@ instance Binary CmdMSG where
+----+-----+-------+------+----------+----------+
--}
+newtype CmdResp = CmdResp (Word8, Maybe Socks5Addr)
+
connError :: CmdResp
connError = CmdResp (1, Nothing)
connSuccess :: Socks5Addr -> CmdResp
connSuccess addr = CmdResp (0, Just addr)
-newtype CmdResp = CmdResp (Word8, Maybe Socks5Addr)
-
instance Binary CmdResp where
get = do
_ <- sockVer
cmd <- get
addr <- get
- return $ CmdResp (cmd, (Just addr))
+ return $ CmdResp (cmd, Just addr)
put (CmdResp (cmd, addr)) = do
putWord8 5
putWord8 cmd
putWord8 0
case addr of
- Nothing -> do
+ Nothing ->
putByteString $ B.pack [1, 0, 0, 0, 0, 0, 0]
Just addr' ->
put addr'
-data Socks5Addr = Socks5Addr4 HostAddress PortNumber
- | Socks5AddrFQDN ByteString PortNumber
- | Socks5Addr6 HostAddress6 PortNumber
+data Socks5Addr = Socks5Addr4 NS.HostAddress NS.PortNumber
+ | Socks5AddrFQDN ByteString NS.PortNumber
+ | Socks5Addr6 NS.HostAddress6 NS.PortNumber
+
+toString :: Socks5Addr -> (String, String)
+toString (Socks5Addr4 h p) = (showIPv4 h, show p)
+toString (Socks5Addr6 h p) = (showIPv6 h, show p)
+toString (Socks5AddrFQDN h p) = (B.unpack h, show p)
instance Binary Socks5Addr where
get = do
@@ -137,33 +148,33 @@ instance Binary Socks5Addr where
1 -> do
h <- getWord32be
p <- getWord16be
- return $ Socks5Addr4 h (PortNum p)
+ return $ Socks5Addr4 h (NS.PortNum p)
4 -> do
w1 <- getWord32be
w2 <- getWord32be
w3 <- getWord32be
w4 <- getWord32be
p <- getWord16be
- return $ Socks5Addr6 (w1, w2, w3, w4) (PortNum p)
+ return $ Socks5Addr6 (w1, w2, w3, w4) (NS.PortNum p)
3 -> do
len <- getWord8
addr <- getByteString $ fromIntegral len
p <- getWord16be
- return $ Socks5AddrFQDN addr (PortNum p)
+ return $ Socks5AddrFQDN addr (NS.PortNum p)
_ -> fail "Invalid Address type"
- put (Socks5Addr4 w (PortNum p)) = do
+ put (Socks5Addr4 w (NS.PortNum p)) = do
putWord32be w
putWord16be p
- put (Socks5Addr6 (w1, w2, w3, w4) (PortNum p)) = do
+ put (Socks5Addr6 (w1, w2, w3, w4) (NS.PortNum p)) = do
putWord32be w1
putWord32be w2
putWord32be w3
putWord32be w4
putWord16be p
- put (Socks5AddrFQDN addr (PortNum p)) = do
+ put (Socks5AddrFQDN addr (NS.PortNum p)) = do
putWord8 $ fromIntegral $ B.length addr
putByteString addr
putWord16be p
@@ -181,3 +192,66 @@ sockVer = word8 5
reserved :: Get Word8
reserved = word8 0
+
+-- Credit:
+-- showIPv4 and showIPv6 are from 'iproute' package
+-- it's available at http://hackage.haskell.org/package/iproute
+-- under BSD3 license
+showIPv4 :: NS.HostAddress -> String
+showIPv4 = show4
+ where
+ remQuo x = (x `mod` 256, x `div` 256)
+ show4 q = printf "%d.%d.%d.%d" a1 a2 a3 a4
+ where
+ (a4,q4) = remQuo q
+ (a3,q3) = remQuo q4
+ (a2,q2) = remQuo q3
+ (a1, _) = remQuo q2
+
+showIPv6 :: NS.HostAddress6 -> String
+showIPv6 (a1,a2,a3,a4) = show6 a1 ++ ":" ++ show6 a2 ++ ":" ++ show6 a3 ++ ":" ++ show6 a4
+ where
+ remQuo x = (x `mod` 65536, x `div` 65536)
+ show6 q = printf "%02x:%02x" r1 r2
+ where
+ (r2,q2) = remQuo q
+ (r1, _) = remQuo q2
+
+-- Credit:
+-- 'connect' is mostly copied from "network-simple".
+-- the only difference is I added the "notify" part.
+
+connect host port notify = bracketNotify connectSock notify (NS.sClose . fst)
+ where
+ connectSock = do
+ (addr:_) <- NS.getAddrInfo (Just hints) (Just host) (Just port)
+ bracketOnErrorNotify
+ (newSocket addr)
+ notify
+ NS.sClose
+ $ \sock -> do
+ let sockAddr = NS.addrAddress addr
+ NS.connect sock sockAddr
+ return (sock, sockAddr)
+
+newSocket :: NS.AddrInfo -> IO NS.Socket
+newSocket addr = NS.socket (NS.addrFamily addr)
+ (NS.addrSocketType addr)
+ (NS.addrProtocol addr)
+
+bracketNotify before notifier after thing =
+ mask $ \restore -> do
+ a <- restore before `onException` notifier
+ r <- restore (thing a) `onException` after a
+ _ <- after a
+ return r
+
+bracketOnErrorNotify before notifier after thing =
+ mask $ \restore -> do
+ a <- restore before `onException` notifier
+ restore (thing a) `onException` after a
+
+hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG]
+ , NS.addrSocketType = NS.Stream }
+
+
View
65 src/socks5.hs
@@ -1,21 +1,19 @@
import Data.ByteString as B (ByteString)
import Data.ByteString.Lazy as BL (toStrict)
+import Data.Binary as Bin (Binary, encode)
import Data.Monoid
-import Data.Binary as Bin (encode, Binary)
-
-import Network.Socket (Socket)
import Control.Concurrent.Async
import Control.Proxy as P
import qualified Control.Proxy.Binary as P
import qualified Control.Proxy.Parse as P (wrap)
-import Control.Proxy.TCP as P
+import qualified Control.Proxy.TCP as P (serve, HostPreference(..), socketReadS, socketWriteD)
import Control.Proxy.Trans.Either as P (EitherP, runEitherK)
import Control.Proxy.Trans.State as P (StateP, evalStateK)
-import Socks5.Internal
+import Socks5.Internal as I
-----------------------------------------------------------------------------
handshake :: (Proxy p, Monad m) =>
@@ -30,67 +28,26 @@ handshake () = do
return dst
toStrictByteString :: Bin.Binary a => a -> B.ByteString
-toStrictByteString = \x -> BL.toStrict $ Bin.encode x
+toStrictByteString = BL.toStrict . Bin.encode
main :: IO ()
-main = serve (Host "127.0.0.1") "8000" $ \(cs, _) -> do
- let sendMsg msg = runProxy $ do
+main = P.serve (P.Host "127.0.0.1") "8000" $ \(cs, _) -> do
+ let sendMsg msg = runProxy $
-- why does this line need 4 more space of indentation?!
(\() -> P.respond $ toStrictByteString msg) >-> P.socketWriteD cs
res <- P.runProxy $ P.evalStateK mempty $ P.runEitherK $
- P.wrap . socketReadS 4096 cs >-> handshake >-> socketWriteD cs
+ P.wrap . P.socketReadS 4096 cs >-> handshake >-> P.socketWriteD cs
+
case res of
Left _ -> sendMsg authError
Right dst ->
-
- P.connect addr port $ \(ss, _ ) -> do
+ I.connect host port notify $ \(ss, _ ) -> do
sendMsg $ connSuccess dst
s1 <- async (runProxy $ P.socketReadS 4096 cs >-> P.socketWriteD ss)
s2 <- async (runProxy $ P.socketReadS 4096 ss >-> P.socketWriteD cs)
waitEither_ s1 s2
where
- addr = undefined
- port = undefined
- myconnect = undefined
-
-
-{--
- -
- -
-
-bracketNotify before notifier after thing =
- mask $ \restore -> do
- a <- restore (before) `onException` notifier
- r <- restore (thing a) `onException` after a
- _ <- after a
- return r
-
-bracketOnErrorNotify before notifier after thing =
- mask $ \restore -> do
- a <- restore (before) `onException` notifier
- restore (thing a) `onException` after a
-
-newSocket :: NS.AddrInfo -> IO NS.Socket
-newSocket addr = NS.socket (NS.addrFamily addr)
- (NS.addrSocketType addr)
- (NS.addrProtocol addr)
-
-
-
-connect host port = E.bracketNotify (connectSock host port) (NS.sClose . fst)
-where
- connectSock host port = do
- (addr:_) <- NS.getAddrInfo (Just hints) (Just host) (Just port)
- bracketOnErrorNotify
- (newSocket addr)
- NS.sClose
- $ \sock -> do
- let sockAddr = NS.addrAddress addr
- NS.connect sock sockAddr
- return (sock, sockAddr)
- where
- hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG]
- , NS.addrSocketType = NS.Stream }
+ (host, port) = toString dst
+ notify = sendMsg connError
- ---}
Please sign in to comment.
Something went wrong with that request. Please try again.