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.2 +version: 0.1.0.3 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy using the client / server architecture. 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 @@ -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 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 @@ -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) 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 @@ -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 () diff --git a/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs b/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs --- a/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs +++ b/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs @@ -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