shadowsocks 1.20141007 → 1.20150811
raw patch · 4 files changed
+129/−189 lines, 4 filesdep +asyncdep +conduit-combinatorsdep +conduit-extradep −network
Dependencies added: async, conduit-combinators, conduit-extra, iproute
Dependencies removed: network
Files
- Shadowsocks/Util.hs +9/−0
- local.hs +62/−99
- server.hs +47/−85
- shadowsocks.cabal +11/−5
Shadowsocks/Util.hs view
@@ -2,10 +2,13 @@ module Shadowsocks.Util ( Config (..) , parseConfigOptions+ , cryptConduit ) where +import Conduit (Conduit, awaitForever, yield, liftIO) import Control.Monad (liftM) import Data.Aeson (decode', FromJSON)+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Maybe (fromMaybe) import GHC.Generics (Generic)@@ -65,3 +68,9 @@ , password = fromMaybe (password c) (_password o) , method = fromMaybe (method c) (_method o) }++cryptConduit :: (ByteString -> IO ByteString)+ -> Conduit ByteString IO ByteString+cryptConduit crypt = awaitForever $ \input -> do+ output <- liftIO $ crypt input+ yield output
local.hs view
@@ -1,116 +1,79 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative ((<$>))-import Control.Concurrent (forkIO, forkFinally, killThread)-import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)-import qualified Control.Exception as E-import Control.Monad (forever, void)-import Data.Char (ord)-import Data.Binary.Get (runGet, getWord16be, getWord32le)-import Data.Binary.Put (runPut, putWord16be)+import Conduit ( Conduit, await, leftover, yield, liftIO+ , (=$), ($$), ($$+), ($$++), ($$+-))+import Control.Concurrent.Async (race_) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as C+import Data.Binary (decode)+import Data.Binary.Get (runGet, getWord16be, getWord32le)+import Data.Char (ord)+import Data.Conduit.Network ( runTCPServer, runTCPClient+ , serverSettings, clientSettings+ , appSource, appSink) import Data.Monoid ((<>))+import Data.IP (fromHostAddress, fromHostAddress6) import GHC.IO.Handle (hSetBuffering, BufferMode(NoBuffering)) import GHC.IO.Handle.FD (stdout)-import Network.Socket hiding (recv)-import Network.Socket.ByteString (recv, sendAll) import Shadowsocks.Encrypt (getEncDec) import Shadowsocks.Util +initLocal :: Conduit ByteString IO ByteString+initLocal = do+ await+ yield "\x05\x00"+ await >>= maybe (return ()) (\request -> do+ let addrType = request `S.index` 3+ request' = S.drop 4 request+ (addr, payload, addrPort) <- case addrType of+ 1 -> do -- IPv4+ let (ip, rest) = S.splitAt 4 request'+ addr = C.pack $ show $ fromHostAddress $ runGet getWord32le+ $ L.fromStrict ip+ return (addr, ip, S.take 2 rest)+ 3 -> do -- domain name+ let addrLen = ord $ C.head request'+ (domain, rest) = S.splitAt (addrLen + 1) request'+ return (S.tail domain, domain, S.take 2 rest)+ 4 -> do -- IPv6+ let (ip, rest) = S.splitAt 16 request'+ addr = C.pack $ show $ fromHostAddress6 $ decode+ $ L.fromStrict ip+ return (addr, ip, S.take 2 rest)+ _ -> error $ C.unpack $ S.snoc "Unknown address type: " addrType+ yield "\x05\x00\x00\x01\x00\x00\x00\x00\x10\x10"+ let addrToSend = S.singleton addrType <> payload <> addrPort+ port = runGet getWord16be $ L.fromStrict addrPort+ liftIO $ C.putStrLn $ "connecting " <> addr <> ":" <> C.pack (show port)+ leftover addrToSend) +initRemote :: (ByteString -> IO ByteString)+ -> Conduit ByteString IO ByteString+initRemote encrypt = do+ mAddrToSend <- await+ case mAddrToSend of+ Just addrToSend -> do+ enc <- liftIO $ encrypt addrToSend+ yield enc+ Nothing -> return ()+ main :: IO ()-main = withSocketsDo $ do- config <- parseConfigOptions- addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))- Nothing- (Just $ show $ local_port config)- let sockAddr = head addrinfos- sock <- socket (addrFamily sockAddr) Stream defaultProtocol- bindSocket sock (addrAddress sockAddr)- listen sock 128- serverAddr <- getServer (server config) (server_port config)+main = do hSetBuffering stdout NoBuffering-- C.hPutStrLn stdout $- "starting local at " <> C.pack (show $ local_port config)- mvar <- newEmptyMVar- forkFinally (serveForever sock config serverAddr)- (\_ -> putMVar mvar ())- takeMVar mvar--serveForever :: Socket -> Config -> AddrInfo -> IO ()-serveForever sock config serverAddr = forever $ do- (conn, _) <- accept sock- void $ forkIO $ sockHandler conn config serverAddr--sockHandler :: Socket -> Config -> AddrInfo -> IO ()-sockHandler conn config serverAddr =- (do+ config <- parseConfigOptions+ let localSettings = serverSettings (local_port config) "*"+ remoteSettings = clientSettings (server_port config)+ (C.pack $ server config)+ C.putStrLn $ "starting local at " <> C.pack (show $ local_port config)+ runTCPServer localSettings $ \client -> do (encrypt, decrypt) <- getEncDec (method config) (password config)- recv conn 262- send conn "\x05\x00"- msg <- recv conn 4- let m = C.unpack msg-- (addr, addr_to_send') <- if ord (m !! 3) == 1- then do- addr_ip <- recv conn 4- addr <- inet_ntoa $ runGet getWord32le $ L.fromStrict addr_ip- return (C.pack addr, addr_ip)- else do- addr_len <- recv conn 1- addr <- recv conn (ord $ head $ C.unpack addr_len)- return (addr, addr_len <> addr)-- addr_port <- recv conn 2- let addr_to_send = S.singleton (msg `S.index` 3) <> addr_to_send' <> addr_port- port = runGet getWord16be $ L.fromStrict addr_port- let reply = "\x05\x00\x00\x01" <> "\x00\x00\x00\x00" <>- L.toStrict (runPut $ putWord16be 2222)- sendAll conn reply-- remote <- socket (addrFamily serverAddr) Stream defaultProtocol- connect remote (addrAddress serverAddr)- encrypt addr_to_send >>= sendAll remote- C.putStrLn $ "connecting " <> addr <> ":" <> C.pack (show port)- wait <- newEmptyMVar- handleTCP conn remote encrypt decrypt wait)- `E.catch` (\e -> do- close conn- void $ print (e :: E.SomeException))--getServer :: HostName -> Int -> IO AddrInfo-getServer hostname port =- head <$> getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))- (Just hostname)- (Just $ show port)--handleTCP :: Socket- -> Socket- -> (ByteString -> IO ByteString)- -> (ByteString -> IO ByteString)- -> MVar ()- -> IO ()-handleTCP conn remote encrypt decrypt wait = do- hdl1 <- forkIO handleLocal- hdl2 <- forkIO handleRemote- takeMVar wait- killThread hdl1- killThread hdl2- close conn- close remote- where- handleLocal = do- inData <- recv conn 4096 >>= encrypt- if S.null inData- then putMVar wait ()- else sendAll remote inData >> handleLocal- handleRemote = do- inData <- recv remote 4096 >>= decrypt- if S.null inData- then putMVar wait ()- else sendAll conn inData >> handleRemote+ (clientSource, ()) <- appSource client $$+ initLocal =$ appSink client+ runTCPClient remoteSettings $ \appServer -> do+ (clientSource', ()) <-+ clientSource $$++ initRemote encrypt =$ appSink appServer+ race_+ (clientSource' $$+- cryptConduit encrypt =$ appSink appServer)+ (appSource appServer $$ cryptConduit decrypt =$ appSink client)
server.hs view
@@ -1,101 +1,63 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative ((<$>))-import Control.Concurrent (forkIO, forkFinally, killThread)-import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)-import qualified Control.Exception as E-import Control.Monad (forever, void, when)-import Data.Char (ord)+import Conduit (Sink, await, liftIO, (=$), ($$), ($$+), ($$+-))+import Control.Concurrent.Async (race_)+import Data.Binary (decode) import Data.Binary.Get (runGet, getWord16be, getWord32le) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as C+import Data.Char (ord)+import Data.Conduit.Network ( runTCPServer, runTCPClient+ , serverSettings, clientSettings+ , appSource, appSink) import Data.Monoid ((<>))+import Data.IP (fromHostAddress, fromHostAddress6) import GHC.IO.Handle (hSetBuffering, BufferMode(NoBuffering)) import GHC.IO.Handle.FD (stdout)-import Network.Socket hiding (recv)-import Network.Socket.ByteString (recv, sendAll) -import Shadowsocks.Encrypt (getEncDec, iv_len)+import Shadowsocks.Encrypt (getEncDec) import Shadowsocks.Util +initRemote :: (ByteString -> IO ByteString)+ -> Sink ByteString IO (ByteString, Int)+initRemote decrypt = await >>= + maybe (error "Invalid request") (\encRequest -> do+ request <- liftIO $ decrypt encRequest+ let addrType = S.head request + request' = S.drop 1 request+ (addr, addrPort) <- case addrType of+ 1 -> do -- IPv4+ let (ip, rest) = S.splitAt 4 request'+ addr = C.pack $ show $ fromHostAddress $ runGet getWord32le+ $ L.fromStrict ip+ return (addr, S.take 2 rest)+ 3 -> do -- domain name+ let addrLen = ord $ C.head request'+ (domain, rest) = S.splitAt (addrLen + 1) request'+ return (S.tail domain, S.take 2 rest)+ 4 -> do -- IPv6+ let (ip, rest) = S.splitAt 16 request'+ addr = C.pack $ show $ fromHostAddress6 $ decode+ $ L.fromStrict ip+ return (addr, S.take 2 rest)+ _ -> error $ C.unpack $ S.snoc "Unknown address type: " addrType + let port = fromIntegral $ runGet getWord16be $ L.fromStrict addrPort+ return (addr, port))+ main :: IO ()-main = withSocketsDo $ do- config <- parseConfigOptions- addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]}))- Nothing- (Just $ show $ server_port config)- let sockAddr = head addrinfos- sock <- socket (addrFamily sockAddr) Stream defaultProtocol- bindSocket sock (addrAddress sockAddr)- listen sock 128+main = do hSetBuffering stdout NoBuffering-- C.hPutStrLn stdout $- "starting server at " <> C.pack (show $ server_port config)- mvar <- newEmptyMVar- forkFinally (serveForever sock config)- (\_ -> putMVar mvar ())- takeMVar mvar--serveForever :: Socket -> Config -> IO ()-serveForever sock config = forever $ do- (conn, _) <- accept sock- void $ forkIO $ sockHandler conn config--sockHandler :: Socket -> Config -> IO ()-sockHandler conn config =- (do+ config <- parseConfigOptions+ let localSettings = serverSettings (server_port config) "*"+ C.putStrLn $ "starting server at " <> C.pack (show $ server_port config)+ runTCPServer localSettings $ \client -> do (encrypt, decrypt) <- getEncDec (method config) (password config)- let methodName = method config- when (methodName /= "table")- (void $ recv conn (iv_len methodName) >>= decrypt)- addrType <- recv conn 1 >>= decrypt-- addr <- if ord (head $ C.unpack addrType) == 1- then do- addr_ip <- recv conn 4 >>= decrypt- inet_ntoa $ runGet getWord32le $ L.fromStrict addr_ip- else do- addr_len <- recv conn 1 >>= decrypt- addr <- recv conn (ord $ head $ C.unpack addr_len) >>= decrypt- return $ C.unpack addr-- addr_port <- recv conn 2 >>= decrypt- let port = runGet getWord16be $ L.fromStrict addr_port-- remoteAddr <- head <$>- getAddrInfo Nothing (Just addr) (Just $ show port)- remote <- socket (addrFamily remoteAddr) Stream defaultProtocol- connect remote (addrAddress remoteAddr)- putStrLn $ "connecting " <> addr <> ":" <> show port- wait <- newEmptyMVar- handleTCP conn remote encrypt decrypt wait)- `E.catch` (\e -> void $ print (e :: E.SomeException))--handleTCP :: Socket- -> Socket- -> (ByteString -> IO ByteString)- -> (ByteString -> IO ByteString)- -> MVar ()- -> IO ()-handleTCP conn remote encrypt decrypt wait = do- hdl1 <- forkIO handleLocal- hdl2 <- forkIO handleRemote- takeMVar wait- killThread hdl1- killThread hdl2- close conn- close remote- where- handleLocal = do- inData <- recv conn 4096 >>= decrypt- if S.null inData- then putMVar wait ()- else sendAll remote inData >> handleLocal- handleRemote = do- inData <- recv remote 4096 >>= encrypt- if S.null inData- then putMVar wait ()- else sendAll conn inData >> handleRemote+ (clientSource, (host, port)) <-+ appSource client $$+ initRemote decrypt+ let remoteSettings = clientSettings port host+ C.putStrLn $ "connecting " <> host <> ":" <> C.pack (show port)+ runTCPClient remoteSettings $ \appServer -> race_+ (clientSource $$+- cryptConduit decrypt =$ appSink appServer)+ (appSource appServer $$ cryptConduit encrypt =$ appSink client)
shadowsocks.cabal view
@@ -1,6 +1,6 @@ name: shadowsocks-version: 1.20141007-synopsis: A fast tunnel proxy that help you get through firewalls+version: 1.20150811+synopsis: A fast SOCKS5 proxy that help you get through firewalls description: Shadowsocks implemented in Haskell. Original python version: <https://github.com/clowwindy/shadowsocks> homepage: https://github.com/rnons/shadowsocks-haskell@@ -12,7 +12,7 @@ category: Web build-type: Simple cabal-version: >= 1.10-tested-with: GHC == 7.8.2+tested-with: GHC == 7.10.2 data-files: config.json source-repository head@@ -27,12 +27,15 @@ other-extensions: OverloadedStrings, DeriveGeneric build-depends: base == 4.*, aeson >= 0.7,+ async >= 2.0, binary >= 0.7, bytestring >= 0.9,+ conduit-combinators >= 1.0,+ conduit-extra >= 1.1, containers >= 0.5, cryptohash >= 0.11, HsOpenSSL >= 0.11,- network >= 2.4,+ iproute >= 1.4, optparse-applicative >= 0.11, unordered-containers >= 0.2 default-language: Haskell2010@@ -45,12 +48,15 @@ other-extensions: OverloadedStrings, DeriveGeneric build-depends: base == 4.*, aeson >= 0.7,+ async >= 2.0, binary >= 0.7, bytestring >= 0.9,+ conduit-combinators >= 1.0,+ conduit-extra >= 1.1, containers >= 0.5, cryptohash >= 0.11, HsOpenSSL >= 0.11,- network >= 2.4,+ iproute >= 1.4, optparse-applicative >= 0.11, unordered-containers >= 0.2 default-language: Haskell2010