moesocks 0.1.0.5 → 0.1.0.6
raw patch · 6 files changed
+213/−205 lines, 6 filesdep −io-streams
Dependencies removed: io-streams
Files
- moesocks.cabal +3/−3
- readme.md +30/−0
- src/Network/MoeSocks/App.hs +97/−84
- src/Network/MoeSocks/BuilderAndParser.hs +4/−4
- src/Network/MoeSocks/Helper.hs +77/−114
- src/Network/MoeSocks/Type.hs +2/−0
moesocks.cabal view
@@ -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
+ readme.md view
@@ -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+++
src/Network/MoeSocks/App.hs view
@@ -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"-}
src/Network/MoeSocks/BuilderAndParser.hs view
@@ -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
src/Network/MoeSocks/Helper.hs view
@@ -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
src/Network/MoeSocks/Type.hs view
@@ -77,3 +77,5 @@ type Cipher = ByteString -> IO ByteString ++