moesocks 0.1.0.2 → 0.1.0.3
raw patch · 5 files changed
+202/−83 lines, 5 files
Files
- moesocks.cabal +1/−1
- src/Network/MoeSocks/App.hs +51/−24
- src/Network/MoeSocks/BuilderAndParser.hs +19/−2
- src/Network/MoeSocks/Helper.hs +95/−26
- src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs +36/−30
moesocks.cabal view
@@ -3,7 +3,7 @@ name: moesocks category: Network-version: 0.1.0.2+version: 0.1.0.3 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy using the client / server architecture.
src/Network/MoeSocks/App.hs view
@@ -12,6 +12,7 @@ import Data.Monoid import Data.Text (Text) import Data.Text.Lens+import Data.Text.Strict.Lens (utf8) import Network.MoeSocks.BuilderAndParser import Network.MoeSocks.Config import Network.MoeSocks.Constant@@ -26,7 +27,6 @@ import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Data.Text.Strict.Lens (utf8) import qualified System.IO.Streams as Stream @@ -56,13 +56,21 @@ _clientRequest <- parseFromStream connectionParser inputStream {-puts - "request: " <> show _clientRequest-}-+ {-Stream.write (Just - builder_To_ByteString --}+ {-connectionReplyBuilder _clientRequest)-}+ {-outputStream-}+ + Stream.write (Just - builder_To_ByteString nonStandardReplyBuilder)+ outputStream let _c = aConfig _initSocket = getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream - logSA "Connect remote" _initSocket - \(_remoteSocket, _remoteAddress) -> do+ logSA "L connect remote" _initSocket - + \(_remoteSocket, _remoteAddress) -> do++ connect _remoteSocket _remoteAddress _localPeerAddr <- getPeerName aSocket@@ -72,7 +80,7 @@ showAddressType (_r ^. addressType) <> ":" <> show (_r ^. portNumber . to portNumber16)- puts - "L " -- <> showConnectionType (_clientRequest ^. connectionType)+ _log - "L " -- <> showConnectionType (_clientRequest ^. connectionType) <> ": " <> ( concat - L.intersperse " -> " @@ -83,10 +91,6 @@ ) let handleLocal __remoteSocket = do- Stream.write (Just - builder_To_ByteString -- connectionReplyBuilder _clientRequest)- outputStream- (remoteInputStream, remoteOutputStream) <- socketToStreams _remoteSocket@@ -107,12 +111,24 @@ remoteInputDecryptedStream <- Stream.mapM _decrypt remoteInputStream-- waitBoth- (Stream.connect inputStream remoteOutputEncryptedStream)- (Stream.connect remoteInputDecryptedStream outputStream) + let+ sendChannel = + Stream.connect inputStream remoteOutputEncryptedStream+ + doneFlag <- newEmptyMVar+ + + let receiveChannel = connectFor doneFlag+ remoteInputDecryptedStream+ outputStream + waitOneDebug + (Just "L -->", sendChannel)+ (Just "L <--", receiveChannel)+ (setDone doneFlag)++ handleLocal _remoteSocket @@ -152,7 +168,7 @@ getSocket _hostName (portNumber16 _port) _socketType - logSA "Connect target" (initTarget _clientRequest) - \_r -> do+ logSA "R connect target" (initTarget _clientRequest) - \_r -> do let (_targetSocket, _targetSocketAddress) = _r connect _targetSocket _targetSocketAddress@@ -160,7 +176,7 @@ _remotePeerAddr <- getPeerName aSocket _targetPeerAddr <- getPeerName _targetSocket - puts - "R " -- <> showConnectionType (_clientRequest ^. connectionType)+ _log - "R " -- <> showConnectionType (_clientRequest ^. connectionType) <> ": " <> ( concat - L.intersperse " -> " - map show@@ -177,9 +193,20 @@ remoteOutputEncryptedStream <- Stream.contramapM _encrypt remoteOutputStream - waitBoth- (Stream.connect remoteInputDecryptedStream targetOutputStream)- (Stream.connect targetInputStream remoteOutputEncryptedStream)+ let sendChannel = + Stream.connect remoteInputDecryptedStream targetOutputStream+++ doneFlag <- newEmptyMVar++ let receiveChannel = + connectFor doneFlag + targetInputStream remoteOutputEncryptedStream++ waitOneDebug + (Just "R -->", sendChannel)+ (Just "R <--", receiveChannel)+ (setDone doneFlag) handleTarget _targetSocket @@ -248,7 +275,7 @@ forM_ maybeConfig - \config -> do let localApp :: (Socket, SockAddr) -> IO ()- localApp s = logSA "Local loop" (pure s) - + localApp s = logSA "L loop" (pure s) - \(_localSocket, _localAddr) -> do putStrLn "Moe local!" @@ -260,13 +287,13 @@ let handleLocal _socket = do (_newSocket, _) <- accept _socket forkIO - catchAll - - logSocket "Local handler" (pure _newSocket) -+ logSocket "L handler" (pure _newSocket) - localRequestHandler config forever - handleLocal _localSocket let remoteApp :: (Socket, SockAddr) -> IO ()- remoteApp s = logSA "Remote loop" (pure s) -+ remoteApp s = logSA "R loop" (pure s) - \(_remoteSocket, _remoteAddr) -> do putStrLn "Moe remote!" @@ -280,7 +307,7 @@ let handleRemote _socket = do (_newSocket, _) <- accept _socket forkIO - catchAll - - logSocket "Remote handler" (pure _newSocket) -+ logSocket "R handler" (pure _newSocket) - remoteRequestHandler config forever - handleRemote _remoteSocket@@ -290,17 +317,17 @@ remoteRun = do let _c = config getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream- >>= catchAllLog "remote" . remoteApp + >>= catchAllLog "R app" . remoteApp localRun :: IO () localRun = do let _c = config getSocket (_c ^. local . _Text) (_c ^. localPort) Stream- >>= catchAllLog "local" . localApp + >>= catchAllLog "L app" . localApp debugRun :: IO () debugRun = do- catchAllLog "both" - waitBoth localRun remoteRun+ catchAllLog "Debug app" - waitBoth localRun remoteRun case options ^. runningMode of
src/Network/MoeSocks/BuilderAndParser.hs view
@@ -54,6 +54,23 @@ socksHeader requestParser +{- Special hack for polipo+ -0500 0001 0000 0000 1010+ -}++nonStandardReplyBuilder :: B.Builder+nonStandardReplyBuilder =+ B.word8 socksVersion+ <> B.word8 _Request_Granted + <> B.word8 _ReservedByte+ <> B.word8 1+ <> B.word8 0+ <> B.word8 0+ <> B.word8 0+ <> B.word8 0+ <> B.word8 16+ <> B.word8 16+ connectionReplyBuilder :: ClientRequest -> B.Builder connectionReplyBuilder _clientRequest = B.word8 socksVersion@@ -67,7 +84,7 @@ case aAddressType of IPv4_address _address -> B.word8 1- <> foldMap B.word8 _address + <> foldMap B.word8 (_address) Domain_name x -> B.word8 3 <> B.word8 (fromIntegral (S.length x))@@ -75,7 +92,7 @@ IPv6_address xs -> B.word8 4- <> B.byteString (S.pack xs)+ <> B.byteString (S.pack - xs)
src/Network/MoeSocks/Helper.hs view
@@ -5,6 +5,7 @@ import Control.Concurrent import Control.Exception import Control.Lens+import Control.Monad import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString)@@ -16,6 +17,7 @@ import Network.Socket import Prelude hiding (take, (-)) import System.IO (hPutStrLn, stderr)+import System.IO.Streams (InputStream, OutputStream) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B@@ -31,8 +33,11 @@ -- END backports +type IB = InputStream ByteString+type OB = OutputStream ByteString+ _Debug :: Bool-_Debug = True+_Debug = False boolToMaybe :: Bool -> Maybe () boolToMaybe True = Just ()@@ -54,6 +59,9 @@ pute :: String -> IO () pute = sync . hPutStrLn stderr +_log :: String -> IO ()+_log = sync . putStrLn+ puteT :: Text -> IO () puteT = pute . view _Text @@ -63,10 +71,15 @@ fromWord8 :: forall t. Binary t => [Word8] -> t fromWord8 = decode . runPut . mapM_ put +logClose :: String -> Socket -> IO ()+logClose _ aSocket = do+ {-puts - "Closing socket " <> aID-}+ close aSocket + logSocketWithAddress :: String -> IO (Socket, SockAddr) -> ((Socket, SockAddr) -> IO a) -> IO a-logSocketWithAddress aID _init f =- catch (bracket _init (close .fst) f) - \e -> do+logSocketWithAddress aID _init f = do+ catch (bracket _init (logClose aID . fst) f) - \e -> do pute - "Exception in " <> aID <> ": " <> show (e :: SomeException) throw e @@ -76,7 +89,7 @@ logSocket :: String -> IO Socket -> (Socket -> IO a) -> IO a logSocket aID _init f =- catch (bracket _init close f) - \e -> do+ catch (bracket _init (logClose aID) f) - \e -> do pute - "Exception in " <> aID <> ": " <> show (e :: SomeException) throw e @@ -94,43 +107,73 @@ pute - "Catch IO: " <> show (e :: IOException) -waitBoth :: IO a -> IO b -> IO ()-waitBoth x y = do- let _init = do- _xLock <- newEmptyMVar- _xThreadID <- - forkFinally x -- const - putMVar _xLock ()+wrapIO :: (Maybe String, IO c) -> IO ()+wrapIO (s, _io) = do+ forM_ s - puts . ("+ " <>)+ _io+ forM_ s - puts . ("- " <>) - _yLock <- newEmptyMVar- _yThreadID <- - forkFinally y -- const - putMVar _yLock ()+waitOneDebug :: (Maybe String, IO ()) -> (Maybe String, IO ()) -> IO () -> IO ()+waitOneDebug x y doneX = do+ waitY <- newEmptyMVar+ forkFinally (wrapIO y) -+ const - putMVar waitY () - return (_xThreadID, _xLock, _yThreadID, _yLock)+ wrapIO x+ {-puts - "waitOneDebug: finalize"-}+ doneX+ {-puts - "waitOneDebug: waiting thread y"-}+ takeMVar waitY - let handleError (xThreadID, _, yThreadID, _) = do- killThread yThreadID- killThread xThreadID+ {-puts - "waitOneDebug: done thread y"-} - let action (_, xLock, _, yLock) = do- takeMVar xLock - takeMVar yLock+-- 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 ())++ action _children = do+ forkChild _children x+ forkChild _children y+ waitForChildren _children+ bracket - _init- handleError+ initChildren+ (const - pure ()) action++waitBoth :: IO () -> IO () -> IO ()+waitBoth x y = do+ waitBothDebug (Nothing, x) (Nothing, y) -pushStream :: (Stream.OutputStream ByteString) -> B.Builder -> IO ()+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@@ -174,3 +217,29 @@ case lookup _from l of Nothing -> l Just v -> (_to,v) : l++setDone :: MVar () -> IO ()+setDone x = do+ {-puts - "setting Done!"-}+ putMVar x ()+ {-puts - "setting done complete"-}+++connectFor :: MVar () -> IB -> OB -> IO ()+connectFor _doneFlag _i _o = do+ {-puts - "connecting"-}++ _i2 <- Stream.lockingInputStream _i+ _o2 <- Stream.lockingOutputStream _o++ let _io = catchIO - Stream.connect _i2 _o2++ _loopThreadID <- forkFinally _io - + const - setDone _doneFlag+ + takeMVar _doneFlag++ {-puts - "killing loop"-}+ killThread _loopThreadID++ pure ()
src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs view
@@ -105,39 +105,45 @@ method ^. _Text ctx <- cipherInitBS cipherMethod key cipher_iv Encrypt let- encrypt "" = return ""- encrypt buf = do- empty <- isEmptyMVar cipherCtx- if empty- then do- putMVar cipherCtx $! ()- ciphered <- withOpenSSL $ cipherUpdateBS ctx buf- return $! cipher_iv <> ciphered- else do- r <- withOpenSSL $ cipherUpdateBS ctx buf- return $! r+ encrypt buf = + if S.null buf+ then return $! S.empty+ else do+ empty <- isEmptyMVar cipherCtx+ if empty+ then do+ putMVar cipherCtx $! ()+ ciphered <- withOpenSSL $ cipherUpdateBS ctx buf+ return $! cipher_iv <> ciphered+ else do+ r <- withOpenSSL $ cipherUpdateBS ctx buf+ return $! r - decrypt "" = return ""- decrypt buf = do- empty <- isEmptyMVar decipherCtx- if empty- then do- let decipher_iv = S.take m1 buf- dctx <- cipherInitBS cipherMethod key decipher_iv Decrypt- putMVar decipherCtx $! dctx- if S.null (S.drop m1 buf)- then return ""- else do- r <- withOpenSSL $- cipherUpdateBS dctx (S.drop m1 buf)- return $! r- else do- dctx <- readMVar decipherCtx- r <- withOpenSSL $ cipherUpdateBS dctx buf- return $! r+ decrypt buf =+ if S.null buf+ then return $! S.empty+ else do+ empty <- isEmptyMVar decipherCtx+ if empty+ then do+ let decipher_iv = S.take m1 buf+ dctx <- cipherInitBS cipherMethod key decipher_iv Decrypt+ putMVar decipherCtx $! dctx+ if S.null (S.drop m1 buf)+ then return ""+ else do+ r <- withOpenSSL $+ cipherUpdateBS dctx (S.drop m1 buf)+ return $! r+ else do+ dctx <- readMVar decipherCtx+ r <- withOpenSSL $ cipherUpdateBS dctx buf+ return $! r return (encrypt, decrypt) getEncDec :: Text -> ByteString -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString)-getEncDec = getSSLEncDec+getEncDec t+ | t == "none" = const $ pure (pure, pure)+ | otherwise = getSSLEncDec t