diff --git a/moesocks.cabal b/moesocks.cabal --- a/moesocks.cabal +++ b/moesocks.cabal @@ -3,7 +3,7 @@ name: moesocks category: Network -version: 0.1.0.5 +version: 0.1.0.6 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy using the client / server architecture. @@ -16,7 +16,8 @@ copyright: Copyright (C) 2015 Jinjing Wang tested-with: GHC == 7.10.1 -extra-source-files: config.json +extra-source-files: config.json + , readme.md source-repository head type: git @@ -28,7 +29,6 @@ build-depends: base > 4 && <= 5 , lens , network - , io-streams , binary , bytestring , unix diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,30 @@ +MoeSocks +======== + + +A socks5 proxy using the client / server architecture. + +MoeSocks is greatly inspired by [shadowsocks]. + +A sample `config.json` file is included in this repository and the cabal archive. + +type `moesocks --help` for help. + +Notes +------ + +Remote mode is still buggy :( + +There is an earlier implementation of [shadowsocks in Haskell] by rnons. + +The goal of moesocks is to provide extra configurability to standard +shadowsocks, for example: + +* load balancing (region based multi-server configuration) +* IP level request filters (like iptables) + +[shadowsocks]:https://github.com/shadowsocks/shadowsocks +[shadowsocks in Haskell]:https://github.com/rnons/shadowsocks-haskell + + + diff --git a/src/Network/MoeSocks/App.hs b/src/Network/MoeSocks/App.hs --- a/src/Network/MoeSocks/App.hs +++ b/src/Network/MoeSocks/App.hs @@ -6,7 +6,7 @@ import Control.Concurrent import Control.Lens import Control.Monad -import Data.Aeson +import Data.Aeson hiding (Result) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) import Data.Monoid @@ -18,22 +18,17 @@ import Network.MoeSocks.Constant import Network.MoeSocks.Helper import Network.MoeSocks.Type -import Network.Socket +import Network.Socket hiding (send, recv) import Prelude hiding ((-), take) -import System.IO.Streams.Attoparsec -import System.IO.Streams.Network -import qualified Data.ByteString.Builder as B +import System.Log.Formatter +import System.Log.Handler.Simple +import System.Log.Logger import qualified Data.HashMap.Strict as H import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.IO as TIO -import qualified System.IO.Streams as Stream - -import qualified System.Log.Handler as LogHandler -import System.Log.Handler.Simple -import System.Log.Formatter -import System.Log.Logger import qualified System.IO as IO +import qualified System.Log.Handler as LogHandler showAddressType :: AddressType -> String showAddressType (IPv4_address xs) = concat - L.intersperse "." - @@ -50,28 +45,30 @@ localRequestHandler:: MoeConfig -> Socket -> IO () localRequestHandler aConfig aSocket = do - (inputStream, outputStream) <- socketToStreams aSocket - - r <- parseFromStream greetingParser inputStream - {-puts - "greetings: " <> show r-} + (_leftBytesAfterGreeting, r) <- + parseSocket mempty pure greetingParser aSocket forM_ (boolToMaybe - _No_authentication `elem` (r ^. authenticationMethods)) - const - do - pushStream outputStream - greetingReplyBuilder + + sendBuilder aSocket greetingReplyBuilder - _clientRequest <- parseFromStream connectionParser inputStream - puts - "L : " <> show _clientRequest + (_leftBytesAfterClientRequest, _clientRequest) <- parseSocket + _leftBytesAfterGreeting + pure + connectionParser + aSocket + puts - "L : " <> show _clientRequest + let _c = aConfig _initSocket = getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream - - logSA "L connect remote" _initSocket - - \(_remoteSocket, _remoteAddress) -> do - + logSA "L remote socket" _initSocket - + \(_remoteSocket, _remoteAddress) -> do connect _remoteSocket _remoteAddress _localPeerAddr <- getPeerName aSocket @@ -83,15 +80,14 @@ let _connectionReplyBuilder = connectionReplyBuilder _remoteSocketName - Stream.write (Just - builder_To_ByteString _connectionReplyBuilder) - outputStream + sendBuilder aSocket _connectionReplyBuilder let showRequest :: ClientRequest -> String showRequest _r = showAddressType (_r ^. addressType) <> ":" <> show (_r ^. portNumber) - _log - "L " <> showConnectionType (_clientRequest ^. connectionType) + _log - "L " -- <> showConnectionType (_clientRequest ^. connectionType) <> ": " <> ( concat - L.intersperse " -> " @@ -102,42 +98,47 @@ ) let handleLocal __remoteSocket = do - - (remoteInputStream, remoteOutputStream) <- - socketToStreams _remoteSocket - (_encrypt, _decrypt) <- getCipher (aConfig ^. method) (aConfig ^. password) let - _header = shadowsocksRequestBuilder _clientRequest - - remoteOutputEncryptedStream <- - Stream.contramapM _encrypt remoteOutputStream - - pushStream remoteOutputEncryptedStream - - B.byteString - builder_To_ByteString _header - - remoteInputDecryptedStream <- - Stream.mapM _decrypt remoteInputStream - - let - sendChannel = - Stream.connect inputStream remoteOutputEncryptedStream - - doneFlag <- newEmptyMVar + _header = shadowSocksRequestBuilder _clientRequest - let receiveChannel = connectFor doneFlag - remoteInputDecryptedStream - outputStream + let sendChannel = do + sendBuilderEncrypted _encrypt __remoteSocket _header - waitOneDebug + when (_leftBytesAfterClientRequest & isn't _Empty) - + send_ __remoteSocket =<< + _encrypt _leftBytesAfterClientRequest + + let sendChannelLoop = do + _r <- recv_ aSocket + if (_r & isn't _Empty) + then do + send_ __remoteSocket =<< _encrypt _r + sendChannelLoop + else do + puts - "0 bytes from remote!" + close aSocket + + sendChannelLoop + + let receiveChannel = do + _r <- recv_ __remoteSocket + if (_r & isn't _Empty) + then do + send_ aSocket =<< _decrypt _r + receiveChannel + else do + puts - "0 bytes from target!" + close __remoteSocket + + runBothDebug (Just "L -->", sendChannel) (Just "L <--", receiveChannel) - (setDone doneFlag) handleLocal _remoteSocket @@ -145,20 +146,20 @@ remoteRequestHandler:: MoeConfig -> Socket -> IO () remoteRequestHandler aConfig aSocket = do - (remoteInputStream, remoteOutputStream) <- socketToStreams aSocket + {-(remoteInputStream, remoteOutputStream) <- socketToStreams aSocket-} (_encrypt, _decrypt) <- getCipher (aConfig ^. method) (aConfig ^. password) - remoteInputDecryptedStream <- Stream.mapM _decrypt remoteInputStream + (_leftOverBytes, _clientRequest) <- parseSocket + mempty + _decrypt + shadowSocksRequestParser + aSocket - _clientRequest <- parseFromStream - shadowsocksRequestParser remoteInputDecryptedStream - {- - -puts - "Remote get: " <> show _clientRequest - -} + puts - "Remote get: " <> show _clientRequest let initTarget :: ClientRequest -> IO (Socket, SockAddr) @@ -179,7 +180,7 @@ getSocket _hostName _port _socketType - logSA "R connect target" (initTarget _clientRequest) - \_r -> do + logSA "R target socket" (initTarget _clientRequest) - \_r -> do let (_targetSocket, _targetSocketAddress) = _r connect _targetSocket _targetSocketAddress @@ -197,29 +198,38 @@ ] ) let - handleTarget __targetSocket = do - (targetInputStream, targetOutputStream) <- - socketToStreams _targetSocket - - remoteOutputEncryptedStream <- - Stream.contramapM _encrypt remoteOutputStream - - let sendChannel = - Stream.connect remoteInputDecryptedStream targetOutputStream + handleTarget __leftOverBytes __targetSocket = do + let sendChannel = do + when (__leftOverBytes & isn't _Empty) - + send_ __targetSocket _leftOverBytes + let sendChannelLoop = do + r <- recv_ aSocket + if (r & isn't _Empty) + then do + send_ __targetSocket =<< _decrypt r + sendChannelLoop + else do + puts - "0 bytes from remote!" + close aSocket - doneFlag <- newEmptyMVar + sendChannelLoop - let receiveChannel = - connectFor doneFlag - targetInputStream remoteOutputEncryptedStream + let receiveChannel = do + r <- recv_ __targetSocket + if (r & isn't _Empty) + then do + send_ aSocket =<< _encrypt r + receiveChannel + else do + puts - "0 bytes from target!" + close __targetSocket - waitOneDebug + runBothDebug (Just "R -->", sendChannel) (Just "R <--", receiveChannel) - (setDone doneFlag) - handleTarget _targetSocket + handleTarget _leftOverBytes _targetSocket parseConfig :: Text -> IO (Maybe MoeConfig) parseConfig aConfigFile = do @@ -289,9 +299,12 @@ let formattedHandler = LogHandler.setFormatter stdoutHandler - - simpleLogFormatter "[$time $prio] $msg" + {-simpleLogFormatter "$time $prio $msg"-} + simpleLogFormatter "$time $msg" updateGlobalLogger rootLoggerName removeHandler + updateGlobalLogger "moe" removeHandler + updateGlobalLogger "moe" - addHandler formattedHandler updateGlobalLogger "moe" - setLevel (options ^. verbosity) @@ -303,7 +316,7 @@ let localApp :: (Socket, SockAddr) -> IO () localApp s = logSA "L loop" (pure s) - \(_localSocket, _localAddr) -> do - puts "Moe local!" + _say "Moe local!" setSocketOption _localSocket ReuseAddr 1 bindSocket _localSocket _localAddr @@ -312,8 +325,8 @@ let handleLocal _socket = do (_newSocket, _) <- accept _socket - forkIO - catchAllLog "L thread" - - logSocket "L handler" (pure _newSocket) - + forkIO - catchExceptAsyncLog "L thread" - + logSocket "L client socket" (pure _newSocket) - localRequestHandler config forever - handleLocal _localSocket @@ -321,7 +334,7 @@ let remoteApp :: (Socket, SockAddr) -> IO () remoteApp s = logSA "R loop" (pure s) - \(_remoteSocket, _remoteAddr) -> do - puts "Moe remote!" + _say "Moe remote!" setSocketOption _remoteSocket ReuseAddr 1 bindSocket _remoteSocket _remoteAddr @@ -332,8 +345,8 @@ let handleRemote _socket = do (_newSocket, _) <- accept _socket - forkIO - catchAllLog "R thread" - - logSocket "R handler" (pure _newSocket) - + forkIO - catchExceptAsyncLog "R thread" - + logSocket "R remote socket" (pure _newSocket) - remoteRequestHandler config forever - handleRemote _remoteSocket @@ -343,17 +356,17 @@ remoteRun = do let _c = config getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream - >>= catchAllLog "R app" . remoteApp + >>= catchExceptAsyncLog "R app" . remoteApp localRun :: IO () localRun = do let _c = config getSocket (_c ^. local . _Text) (_c ^. localPort) Stream - >>= catchAllLog "L app" . localApp + >>= catchExceptAsyncLog "L app" . localApp debugRun :: IO () debugRun = do - catchAllLog "Debug app" - do + catchExceptAsyncLog "Debug app" - do {-puts "Waiting ..."-} {-threadDelay 1000000 -- wait last instance terminate-} {-puts "Done"-} diff --git a/src/Network/MoeSocks/BuilderAndParser.hs b/src/Network/MoeSocks/BuilderAndParser.hs --- a/src/Network/MoeSocks/BuilderAndParser.hs +++ b/src/Network/MoeSocks/BuilderAndParser.hs @@ -156,8 +156,8 @@ <> addressTypeBuilder (aClientRequest ^. addressType) <> portBuilder (aClientRequest ^. portNumber) -shadowsocksRequestBuilder :: ClientRequest -> B.Builder -shadowsocksRequestBuilder aClientRequest = +shadowSocksRequestBuilder :: ClientRequest -> B.Builder +shadowSocksRequestBuilder aClientRequest = addressTypeBuilder (aClientRequest ^. addressType) <> portBuilder (aClientRequest ^. portNumber) @@ -192,8 +192,8 @@ ] -shadowsocksRequestParser :: Parser ClientRequest -shadowsocksRequestParser = do +shadowSocksRequestParser :: Parser ClientRequest +shadowSocksRequestParser = do __addressType <- addressTypeParser __portNumber <- portParser diff --git a/src/Network/MoeSocks/Helper.hs b/src/Network/MoeSocks/Helper.hs --- a/src/Network/MoeSocks/Helper.hs +++ b/src/Network/MoeSocks/Helper.hs @@ -3,6 +3,7 @@ module Network.MoeSocks.Helper where +import Data.Attoparsec.ByteString import Control.Concurrent import Control.Exception import Control.Lens @@ -15,15 +16,13 @@ import Data.Text.Lens import Data.Text.Strict.Lens (utf8) import Network.MoeSocks.Internal.ShadowSocks.Encrypt -import Network.Socket +import Network.Socket hiding (send, recv) +import Network.Socket.ByteString import Prelude hiding (take, (-)) -import System.IO.Streams (InputStream, OutputStream) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Builder.Extra as BE import qualified Data.ByteString.Lazy as LB -import qualified System.IO.Streams as Stream import System.Log.Logger @@ -35,12 +34,6 @@ -- END backports -type IB = InputStream ByteString -type OB = OutputStream ByteString - -_Debug :: Bool -_Debug = False - flip4 :: (a, b, c, d) -> (d, c, b, a) flip4 (_a, _b, _c, _d) = (_d, _c, _b, _a) @@ -57,14 +50,17 @@ io <* takeMVar syncLock puts :: String -> IO () -puts = sync . debugM "moe" +puts = sync . debugM "moe" . ("😽 " <>) pute :: String -> IO () -pute = sync . errorM "moe" +pute = sync . errorM "moe" . ("😾 " <>) _log :: String -> IO () -_log = sync . infoM "moe" +_log = sync . infoM "moe" . ("😺 " <>) +_say :: String -> IO () +_say = sync . noticeM "moe" . ("😼 " <>) + puteT :: Text -> IO () puteT = pute . view _Text @@ -73,8 +69,8 @@ logClose :: String -> Socket -> IO () -logClose _ aSocket = do - {-puts - "Closing socket " <> aID-} +logClose aID aSocket = do + puts - "Closing socket " <> aID close aSocket logSocketWithAddress :: String -> IO (Socket, SockAddr) -> @@ -95,8 +91,8 @@ pute - "Exception in " <> aID <> ": " <> show (e :: SomeException) throw e -catchAllLog :: String -> IO a -> IO () -catchAllLog aID io = catches (() <$ io) +catchExceptAsyncLog :: String -> IO a -> IO () +catchExceptAsyncLog aID io = catches (() <$ io) [ Handler - \(e :: AsyncException) -> do pute - "ASyncException in " @@ -109,107 +105,58 @@ <> " : " <> show e ] -catchIO:: IO a -> IO () -catchIO io = catch (() <$ io) - \e -> - pute - "Catch IO: " <> show (e :: IOException) +catchIO:: String -> IO a -> IO () +catchIO aID io = catch (() <$ io) - \e -> + pute - "Catch IO in " <> aID <> ": " + <> show (e :: IOException) wrapIO :: (Maybe String, IO c) -> IO c wrapIO (s, _io) = do pure s - {-forM_ s - puts . ("+ " <>)-} + forM_ s - puts . ("+ " <>) _io - {-<* (forM_ s - puts . ("- " <>))-} - -waitOneDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () -> IO () -waitOneDebug x y doneX = do - waitY <- newEmptyMVar - forkFinally (wrapIO y) - - const - putMVar waitY () - - wrapIO x - {-puts - "waitOneDebug: finalize"-} - doneX - {-puts - "waitOneDebug: waiting thread y"-} - takeMVar waitY - - {-puts - "waitOneDebug: done thread y"-} - --- killThread yThreadID - -waitBothDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () -waitBothDebug x y = do - let - initChildren :: IO (MVar [MVar ()]) - initChildren = newMVar [] - - waitForChildren :: (MVar [MVar ()]) -> IO () - waitForChildren _children = do - cs <- takeMVar _children - case cs of - [] -> return () - m:ms -> do - putMVar _children ms - takeMVar m - waitForChildren _children - - forkChild :: (MVar [MVar ()]) -> (Maybe String, IO ()) -> IO ThreadId - forkChild _children io = do - mvar <- newEmptyMVar - childs <- takeMVar _children - putMVar _children (mvar:childs) - forkFinally (wrapIO io) (\_ -> putMVar mvar ()) + <* (forM_ s - puts . ("- " <>)) + +runBoth :: IO () -> IO () -> IO () +runBoth x y = do + runBothDebug (Nothing, x) (Nothing, y) - action _children = do - forkChild _children x - forkChild _children y - waitForChildren _children +runBothDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () +runBothDebug x y = do + let _x = wrapIO x + _y = wrapIO y - bracket - initChildren - (const - pure ()) - action + _threadXDone <- newEmptyMVar + _threadYDone <- newEmptyMVar -waitBoth :: IO () -> IO () -> IO () -waitBoth x y = do - waitBothDebug (Nothing, x) (Nothing, y) - -runBoth :: IO a -> IO b -> IO () -runBoth x y = do let _init = do - (xThreadID, xLock) <- do - _lock <- newEmptyMVar - _threadID <- - forkFinally x - - const - putMVar _lock () - - return (_threadID, _lock) + xThreadID <- + forkFinally _x - + const - putMVar _threadXDone () yThreadID <- - forkFinally y - const - killThread xThreadID + forkFinally _y - const - do + _threadXRunning <- isEmptyMVar _threadXDone + putMVar _threadYDone () + when _threadXRunning - killThread xThreadID - return (xThreadID, xLock, yThreadID) + return (xThreadID, yThreadID) - let handleError (xThreadID, _, yThreadID) = do + let handleError (xThreadID, yThreadID) = do killThread yThreadID killThread xThreadID - let action (_, xLock, yThreadID) = do - takeMVar xLock - killThread yThreadID + let action (_, yThreadID) = do + takeMVar _threadXDone + _threadYRunning <- isEmptyMVar _threadYDone + when _threadYRunning - killThread yThreadID bracket _init handleError action -pushStream :: (OutputStream ByteString) -> B.Builder -> IO () -pushStream s b = do - _builderStream <- Stream.builderStream s - Stream.write (Just b) _builderStream - Stream.write (Just BE.flush) _builderStream - - getSocket :: (Integral i, Show i) => HostName -> i -> SocketType -> IO (Socket, SockAddr) getSocket aHost aPort aSocketType = do @@ -227,7 +174,7 @@ _socket <- socket family socketType protocol - {-puts - "Getting socket: " <> show address-} + puts - "Getting socket: " <> show address pure (_socket, address) @@ -235,6 +182,7 @@ hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV] , addrSocketType = aSocketType + , addrFamily = AF_INET } builder_To_ByteString :: B.Builder -> ByteString @@ -262,29 +210,44 @@ Nothing -> l Just v -> (_to,v) : l -setDone :: MVar () -> IO () -setDone x = do - {-puts - "setting Done!"-} - putMVar x () - {-puts - "setting done complete"-} +recv_ :: Socket -> IO ByteString +recv_ = flip recv 4096 -connectFor :: MVar () -> IB -> OB -> IO () -connectFor _doneFlag _i _o = do - {-puts - "connecting"-} +send_ :: Socket -> ByteString -> IO () +send_ = sendAll - _i2 <- Stream.lockingInputStream _i - _o2 <- Stream.lockingOutputStream _o +sendBuilder :: Socket -> B.Builder -> IO () +sendBuilder aSocket = send_ aSocket . builder_To_ByteString - let _io = catchIO - Stream.connect _i2 _o2 +sendBuilderEncrypted :: (ByteString -> IO ByteString) -> + Socket -> B.Builder -> IO () +sendBuilderEncrypted _encrypt aSocket x = send_ aSocket =<< + _encrypt (builder_To_ByteString x) - _loopThreadID <- forkFinally _io - - const - setDone _doneFlag - - takeMVar _doneFlag +-- | An exception raised when parsing fails. +data ParseException = ParseException String - {-puts - "killing loop"-} - killThread _loopThreadID +instance Show ParseException where + show (ParseException s) = "Parse exception: " ++ s - pure () +instance Exception ParseException +parseSocket :: ByteString -> (ByteString -> IO ByteString) -> + Parser a -> Socket -> IO (ByteString, a) +parseSocket _left _decrypt aParser = parseSocketWith - parse aParser + where + parseSocketWith :: (ByteString -> Result a) -> + Socket -> IO (ByteString, a) + parseSocketWith _parser _socket = do + _rawBytes <- recv_ _socket + {-puts - "rawBytes: " <> show _rawBytes-} + _bytes <- _decrypt _rawBytes + + let r = _parser - _left <> _bytes + case r of + Done i _r -> pure (i, _r) + Fail _ _ msg -> throwIO - ParseException - + "Failed to parse shadowSocksRequestParser: " + <> msg + Partial _p -> parseSocketWith _p _socket diff --git a/src/Network/MoeSocks/Type.hs b/src/Network/MoeSocks/Type.hs --- a/src/Network/MoeSocks/Type.hs +++ b/src/Network/MoeSocks/Type.hs @@ -77,3 +77,5 @@ type Cipher = ByteString -> IO ByteString + +