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.8 +version: 0.1.0.9 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy using the client / server architecture. diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -6,24 +6,40 @@ MoeSocks is greatly inspired by [shadowsocks]. -A sample `config.json` file is included in this repository and the cabal archive. +A sample `config.json` file is included in this repository and the cabal +archive. type `moesocks --help` for help. -Notes +Features +-------- +* GFW compatibility +* Can be used as a drop in replacement of shadowsocks (only client mode) +* TCP port forwarding + +Planning features +------------------ +* UDP socks5 proxy +* UDP port forwarding +* Web based monitoring and profiling + +Note ------ -Remote mode is still buggy :( +You might want to use the python implementation of [shadowsocks] on the remote +server. +The remote mode of moesocks 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) +* load balancing (region based multi-server configuration) IP level request +* filters (like iptables) -[shadowsocks]:https://github.com/shadowsocks/shadowsocks +[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 @@ -141,34 +141,39 @@ sendChannel _encrypt _header when (_partialBytesAfterClientRequest & isn't _Empty) - - writeChan sendChannel =<< + writeChan sendChannel . Just =<< _encrypt _partialBytesAfterClientRequest - let _produce = produceLoop + let _produce = produceLoop "L send produceLoop" aSocket sendChannel _encrypt - let _consume = consumeLoop + let _consume = consumeLoop "L send consumeLoop" __remoteSocket sendChannel - runBoth _produce _consume - + waitBothDebug (Just "L send produce", _produce) + (Just "L send consume", _consume) + + shutdown __remoteSocket ShutdownSend let receiveThread = do - let _produce = produceLoop + let _produce = produceLoop "L receive produceLoop" __remoteSocket receiveChannel _decrypt - let _consume = consumeLoop + let _consume = consumeLoop "L receive consumeLoop" aSocket receiveChannel - runBoth _produce _consume + waitBothDebug (Just "L receive produce", _produce) + (Just "L receive consume", _consume) - runBothDebug + shutdown aSocket ShutdownSend + + waitBothDebug (Just "L -->", sendThread) (Just "L <--", receiveThread) @@ -235,33 +240,38 @@ let sendThread = do when (_leftOverBytes & isn't _Empty) - - writeChan sendChannel _leftOverBytes + writeChan sendChannel - Just _leftOverBytes - let _produce = produceLoop + let _produce = produceLoop "R send produceLoop" aSocket sendChannel _decrypt - let _consume = consumeLoop + let _consume = consumeLoop "R send consumeLoop" __targetSocket sendChannel - runBoth _produce _consume + waitBothDebug (Just "R send produce", _produce) + (Just "R send consume", _consume) + shutdown __targetSocket ShutdownSend let receiveThread = do - let _produce = produceLoop + let _produce = produceLoop "R send produceLoop" __targetSocket receiveChannel _encrypt - let _consume = consumeLoop + let _consume = consumeLoop "R send consumeLoop" aSocket receiveChannel - runBoth _produce _consume + waitBothDebug (Just "R receive produce", _produce) + (Just "R receive consume", _consume) - runBothDebug + shutdown aSocket ShutdownSend + + waitBothDebug (Just "R -->", sendThread) (Just "R <--", receiveThread) @@ -377,6 +387,8 @@ let handleLocal _socket = do (_newSocket, _) <- accept _socket setSocketCloseOnExec _newSocket + -- send immediately! + setSocketOption _socket NoDelay 1 forkIO - catchExceptAsyncLog "L thread" - logSocket "L client socket" (pure _newSocket) - @@ -407,6 +419,8 @@ let handleRemote _socket = do (_newSocket, _) <- accept _socket setSocketCloseOnExec _newSocket + -- send immediately! + setSocketOption _socket NoDelay 1 forkIO - catchExceptAsyncLog "R thread" - logSocket "R remote socket" (pure _newSocket) - @@ -444,7 +458,7 @@ debugRun :: IO () debugRun = do catchExceptAsyncLog "Debug app" - do - runBoth localRun remoteRun + waitNone localRun remoteRun io - case _options ^. runningMode of DebugMode -> debugRun 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 @@ -28,6 +28,8 @@ import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LB +import Data.Maybe + -- BEGIN backports infixr 0 - @@ -101,64 +103,103 @@ catchExceptAsyncLog aID aIO = catches (() <$ aIO) [ Handler - \(e :: AsyncException) -> do - pute - "ASyncException in " + puts - "ASyncException in " <> aID <> " : " <> show e throw e , Handler - \(e :: SomeException) -> - pute - "CatcheAll in " + puts - "CatcheAll in " <> aID <> " : " <> show e ] catchIO:: String -> IO a -> IO () catchIO aID aIO = catch (() <$ aIO) - \e -> - pute - "Catch IO in " <> aID <> ": " + puts - "Catch IO in " <> aID <> ": " <> show (e :: IOException) -wrapIO :: (Maybe String, IO c) -> IO c +wrapIO :: (Maybe String, IO c) -> IO () wrapIO (s, _io) = do pure s {-forM_ s - puts . ("+ " <>)-} - _io + catchExceptAsyncLog (fromMaybe "" s) _io + {-catch (() <$ _io) - \(e :: IOException) -> pure ()-} {-<* (forM_ s - puts . ("- " <>))-} -runBoth :: IO () -> IO () -> IO () -runBoth x y = do - runBothDebug (Nothing, x) (Nothing, y) +{-waitFirst :: IO () -> IO () -> IO ()-} +{-waitFirst = runWait True False-} -runBothDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () -runBothDebug x y = do +{-waitFirstDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO ()-} +{-waitFirstDebug = runWaitDebug True False-} + +waitBoth :: IO () -> IO () -> IO () +waitBoth = runWait True True + +waitBothDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () +waitBothDebug = runWaitDebug True True + +waitNone :: IO () -> IO () -> IO () +waitNone = runWait False False + +waitNoneDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () +waitNoneDebug = runWaitDebug False False + +runWait :: Bool -> Bool -> IO () -> IO () -> IO () +runWait _waitX _waitY x y = do + runWaitDebug _waitX _waitY (Nothing, x) (Nothing, y) + +runWaitDebug :: Bool -> Bool -> (Maybe String, IO ()) -> + (Maybe String, IO ()) -> IO () +runWaitDebug _waitX _waitY x y = do let _x = wrapIO x _y = wrapIO y - _threadXDone <- newEmptyMVar - _threadYDone <- newEmptyMVar + _xID = x ^. _1 & fromMaybe "" + _yID = y ^. _1 & fromMaybe "" + _hID = _xID <> " / " <> _yID let _init = do + _threadXDone <- newEmptyMVar + _threadYDone <- newEmptyMVar xThreadID <- forkFinally _x - const - putMVar _threadXDone () yThreadID <- forkFinally _y - const - do - _threadXRunning <- isEmptyMVar _threadXDone + when (not _waitX) - do + _threadXRunning <- isEmptyMVar _threadXDone + when _threadXRunning - killThread xThreadID + puts - "killing thread X: " <> _xID + putMVar _threadYDone () - when _threadXRunning - killThread xThreadID - return (xThreadID, yThreadID) + return ((_threadXDone, xThreadID), (_threadYDone, yThreadID)) - let handleError (xThreadID, yThreadID) = do - killThread yThreadID - killThread xThreadID + let handleError ((_, xThreadID), (_, yThreadID)) = do + puts - "handleError for " <> _hID + pure xThreadID + pure yThreadID + pure () + {-killThread yThreadID-} + {-killThread xThreadID-} - let action (_, yThreadID) = do - takeMVar _threadXDone - _threadYRunning <- isEmptyMVar _threadYDone - when _threadYRunning - killThread yThreadID + let action ((_threadXDone, _), (_threadYDone, yThreadID)) = do + catchExceptAsyncLog _hID - do + {-puts - "waiting for " <> _xID-} + takeMVar _threadXDone - bracket + when (not _waitY) - do + _threadYRunning <- isEmptyMVar _threadYDone + when _threadYRunning - killThread yThreadID + {-puts - "killing thread Y: " <> _yID-} + + {-puts - "waiting for " <> _yID-} + takeMVar _threadYDone + {-puts - "All done for " <> _hID-} + + bracketOnError _init handleError action @@ -182,6 +223,9 @@ _socket <- socket family socketType protocol setSocketCloseOnExec _socket + -- send immediately! + setSocketOption _socket NoDelay 1 + {-puts - "Getting socket: " <> show address-} pure (_socket, address) @@ -225,12 +269,12 @@ send_ :: Socket -> ByteString -> IO () send_ = sendAll -sendBuilder :: Chan ByteString -> B.Builder -> IO () -sendBuilder _chan = writeChan _chan . builder_To_ByteString +sendBuilder :: Chan (Maybe ByteString) -> B.Builder -> IO () +sendBuilder _chan = writeChan _chan . Just . builder_To_ByteString -sendBuilderEncrypted :: Chan ByteString -> (ByteString -> IO ByteString) -> - B.Builder -> IO () -sendBuilderEncrypted _chan _encrypt x = writeChan _chan =<< +sendBuilderEncrypted :: Chan (Maybe ByteString) -> + (ByteString -> IO ByteString) -> B.Builder -> IO () +sendBuilderEncrypted _chan _encrypt x = writeChan _chan . Just =<< _encrypt (builder_To_ByteString x) -- | An exception raised when parsing fails. @@ -259,23 +303,35 @@ "Failed to parse " <> _id <> ": " <> msg Partial _p -> parseSocketWith _id _p _socket -produceLoop :: Socket -> Chan ByteString -> +produceLoop :: String -> Socket -> Chan (Maybe ByteString) -> (ByteString -> IO ByteString) -> IO () -produceLoop aSocket aChan f = _produce +produceLoop aID aSocket aChan f = _produce where _produce = do - _r <- recv_ aSocket + _r <- recv_ aSocket `catch` \(e :: IOException) -> + do + puts - aID <> ": " <> show e + pure mempty + if (_r & isn't _Empty) then do - f _r >>= writeChan aChan + f _r >>= writeChan aChan . Just _produce else do - {-puts - "0 bytes from remote!"-} - close aSocket + writeChan aChan Nothing -consumeLoop :: Socket -> Chan ByteString -> IO () -consumeLoop aSocket aChan = - forever - readChan aChan >>= send_ aSocket +consumeLoop :: String -> Socket -> Chan (Maybe ByteString) -> IO () +consumeLoop aID aSocket aChan = _consume + where + _consume = do + _r <- readChan aChan + case _r of + Nothing -> do + pure () + Just _data -> do + (send_ aSocket _data >> _consume) `catch` + \(e :: IOException) -> + (puts - aID <> ": " <> show e) -- Copied and slightly modified from: diff --git a/src/Network/MoeSocks/Options.hs b/src/Network/MoeSocks/Options.hs --- a/src/Network/MoeSocks/Options.hs +++ b/src/Network/MoeSocks/Options.hs @@ -80,11 +80,9 @@ parseForwarding :: String -> [LocalForwarding] parseForwarding x = - let r = x ^. from _Text & parseOnly forwardingListParser - in - case r of - Left _ -> [] - Right xs -> xs + x ^. from _Text + & parseOnly forwardingListParser + & toListOf (traverse . traverse) in