moesocks 0.1.0.8 → 0.1.0.9
raw patch · 5 files changed
+151/−67 lines, 5 files
Files
- moesocks.cabal +1/−1
- readme.md +22/−6
- src/Network/MoeSocks/App.hs +32/−18
- src/Network/MoeSocks/Helper.hs +93/−37
- src/Network/MoeSocks/Options.hs +3/−5
moesocks.cabal view
@@ -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.
readme.md view
@@ -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
src/Network/MoeSocks/App.hs view
@@ -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
src/Network/MoeSocks/Helper.hs view
@@ -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:
src/Network/MoeSocks/Options.hs view
@@ -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