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.6 +version: 0.1.0.7 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy using the client / server architecture. @@ -38,12 +38,13 @@ , optparse-applicative , aeson , unordered-containers - , transformers , HsOpenSSL , containers , cryptohash , safe , hslogger + , transformers + , mtl hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,9 +1,19 @@ module Main where +import Control.Monad.Except +import Control.Monad.Reader hiding (local) import Network.MoeSocks.App +import Network.MoeSocks.Helper import Network.MoeSocks.Options import Options.Applicative hiding (Parser) +import Prelude hiding ((-)) +import System.Exit main :: IO () -main = execParser opts >>= moeApp +main = do + _options <- execParser opts + r <- runExceptT - runReaderT moeApp _options + case r of + Left e -> pute e >> exitFailure + Right _ -> pure () 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 @@ -3,13 +3,16 @@ module Network.MoeSocks.App where + import Control.Concurrent import Control.Lens import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader hiding (local) +import Control.Monad.Writer hiding (listen) import Data.Aeson hiding (Result) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) -import Data.Monoid import Data.Text (Text) import Data.Text.Lens import Data.Text.Strict.Lens (utf8) @@ -30,10 +33,14 @@ import qualified System.IO as IO import qualified System.Log.Handler as LogHandler -showAddressType :: AddressType -> String -showAddressType (IPv4_address xs) = concat - L.intersperse "." - +import OpenSSL (withOpenSSL) +import OpenSSL.EVP.Cipher (getCipherByName) + +showAddressType :: AddressType -> Text +showAddressType (IPv4_address xs) = view (from _Text) - + concat - L.intersperse "." - map show - xs ^.. each -showAddressType (Domain_name x) = x ^. _Text +showAddressType (Domain_name x) = x showAddressType x = error - "IPv6 target not supported:" <> show x @@ -45,17 +52,17 @@ localRequestHandler:: MoeConfig -> Socket -> IO () localRequestHandler aConfig aSocket = do - (_leftBytesAfterGreeting, r) <- - parseSocket mempty pure greetingParser aSocket + (_partialBytesAfterGreeting, r) <- + parseSocket "clientGreeting" mempty pure greetingParser aSocket forM_ (boolToMaybe - _No_authentication `elem` (r ^. authenticationMethods)) - const - do - - sendBuilder aSocket greetingReplyBuilder + send_ aSocket - builder_To_ByteString greetingReplyBuilder - (_leftBytesAfterClientRequest, _clientRequest) <- parseSocket - _leftBytesAfterGreeting + (_partialBytesAfterClientRequest, _clientRequest) <- parseSocket + "clientRequest" + _partialBytesAfterGreeting pure connectionParser aSocket @@ -65,26 +72,22 @@ let _c = aConfig _initSocket = - getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream + getSocket (_c ^. remote) (_c ^. remotePort) Stream logSA "L remote socket" _initSocket - \(_remoteSocket, _remoteAddress) -> do connect _remoteSocket _remoteAddress _localPeerAddr <- getPeerName aSocket - _remoteSocketName <- getSocketName _remoteSocket - {-puts - "remoteSocketName: " <> show _remoteSocketName-} - {-puts- "socket pair: " <> show (sockAddr_To_Pair _remoteSocketName)-} - let _connectionReplyBuilder = connectionReplyBuilder _remoteSocketName - sendBuilder aSocket _connectionReplyBuilder + send_ aSocket - builder_To_ByteString _connectionReplyBuilder let showRequest :: ClientRequest -> String showRequest _r = - showAddressType (_r ^. addressType) + view _Text (showAddressType (_r ^. addressType)) <> ":" <> show (_r ^. portNumber) _log - "L " -- <> showConnectionType (_clientRequest ^. connectionType) @@ -106,39 +109,44 @@ let _header = shadowSocksRequestBuilder _clientRequest - - let sendChannel = do - sendBuilderEncrypted _encrypt __remoteSocket _header + sendChannel <- newChan + receiveChannel <- newChan - when (_leftBytesAfterClientRequest & isn't _Empty) - - send_ __remoteSocket =<< - _encrypt _leftBytesAfterClientRequest + let sendThread = do + sendBuilderEncrypted + sendChannel _encrypt _header - 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 + when (_partialBytesAfterClientRequest & isn't _Empty) - + writeChan sendChannel =<< + _encrypt _partialBytesAfterClientRequest - sendChannelLoop + let _produce = produceLoop + aSocket + sendChannel + _encrypt - 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 + let _consume = consumeLoop + __remoteSocket + sendChannel + runBoth _produce _consume + + + let receiveThread = do + let _produce = produceLoop + __remoteSocket + receiveChannel + _decrypt + + let _consume = consumeLoop + aSocket + receiveChannel + + runBoth _produce _consume + runBothDebug - (Just "L -->", sendChannel) - (Just "L <--", receiveChannel) + (Just "L -->", sendThread) + (Just "L <--", receiveThread) handleLocal _remoteSocket @@ -146,13 +154,12 @@ remoteRequestHandler:: MoeConfig -> Socket -> IO () remoteRequestHandler aConfig aSocket = do - {-(remoteInputStream, remoteOutputStream) <- socketToStreams aSocket-} - (_encrypt, _decrypt) <- getCipher (aConfig ^. method) (aConfig ^. password) (_leftOverBytes, _clientRequest) <- parseSocket + "clientRequest" mempty _decrypt shadowSocksRequestParser @@ -199,44 +206,48 @@ ) let handleTarget __leftOverBytes __targetSocket = do - let sendChannel = do - when (__leftOverBytes & isn't _Empty) - - send_ __targetSocket _leftOverBytes + sendChannel <- newChan + receiveChannel <- newChan - 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 + let sendThread = do + when (_leftOverBytes & isn't _Empty) - + writeChan sendChannel _leftOverBytes - sendChannelLoop + let _produce = produceLoop + aSocket + sendChannel + _decrypt - 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 + let _consume = consumeLoop + __targetSocket + sendChannel + runBoth _produce _consume + + + let receiveThread = do + let _produce = produceLoop + __targetSocket + receiveChannel + _encrypt + + let _consume = consumeLoop + aSocket + receiveChannel + + runBoth _produce _consume + runBothDebug - (Just "R -->", sendChannel) - (Just "R <--", receiveChannel) + (Just "R -->", sendThread) + (Just "R <--", receiveThread) handleTarget _leftOverBytes _targetSocket -parseConfig :: Text -> IO (Maybe MoeConfig) -parseConfig aConfigFile = do - _configFile <- TIO.readFile - aConfigFile ^. _Text +parseConfig :: Text -> MoeMonadT MoeConfig +parseConfig aFilePath = do + _configFile <- io - TIO.readFile - aFilePath ^. _Text let - fromShadowSocksConfig :: [(Text, Value)] -> [(Text, Value)] fromShadowSocksConfig _configList = let fixes = @@ -263,7 +274,7 @@ over (mapped . _1) (T.cons '_') & H.fromList fixConfig _ = Null - _maybeConfig = _v >>= decode . encode . fixConfig + _maybeConfig = _v >>= decode . encode . fixConfig :: Maybe MoeConfig formatConfig :: Value -> Value @@ -277,65 +288,78 @@ case _maybeConfig of Nothing -> do - pute "Failed to parse configuration file" - pute "Example: " + let _r = + execWriter - do + tell "\n\n" + tell "Failed to parse configuration file\n" + tell "Example: \n" - let configBS :: ByteString - configBS = toStrict .encode . formatConfig . toJSON - - defaultMoeConfig - - puteT - configBS ^. utf8 + let configBS :: ByteString + configBS = toStrict .encode . formatConfig . toJSON - + defaultMoeConfig + + tell - configBS ^. utf8 <> "\n" - pure Nothing - _config -> do + throwError - _r ^. _Text + + Just _config -> do pure - _config -moeApp:: MoeOptions -> IO () -moeApp options = do - stdoutHandler <- streamHandler IO.stdout DEBUG - {-puts - "stdoutHandler Level" <> -} - {-show (LogHandler.getLevel stdoutHandler)-} - +initLogger :: Priority -> IO () +initLogger aLevel = do + stdoutHandler <- streamHandler IO.stdout DEBUG let formattedHandler = LogHandler.setFormatter stdoutHandler - - {-simpleLogFormatter "$time $prio $msg"-} simpleLogFormatter "$time $msg" updateGlobalLogger rootLoggerName removeHandler - updateGlobalLogger "moe" removeHandler + updateGlobalLogger "moe" removeHandler updateGlobalLogger "moe" - addHandler formattedHandler + updateGlobalLogger "moe" - setLevel aLevel - updateGlobalLogger "moe" - setLevel (options ^. verbosity) - +moeApp:: MoeMonadT () +moeApp = do + _options <- ask + io - initLogger - _options ^. verbosity + + _config <- parseConfig - _options ^. configFile - maybeConfig <- parseConfig - options ^. configFile + let _method = _config ^. method . _Text - forM_ maybeConfig - \config -> do - let localApp :: (Socket, SockAddr) -> IO () - localApp s = logSA "L loop" (pure s) - - \(_localSocket, _localAddr) -> do - _say "Moe local!" - - setSocketOption _localSocket ReuseAddr 1 - bindSocket _localSocket _localAddr + _cipher <- io - withOpenSSL - getCipherByName _method - listen _localSocket 1 + case _cipher of + Nothing -> throwError - "Invalid method '" + <> _method + <> "' in " + <> _options ^. configFile . _Text + Just _ -> pure () - let handleLocal _socket = do - (_newSocket, _) <- accept _socket - forkIO - catchExceptAsyncLog "L thread" - - logSocket "L client socket" (pure _newSocket) - - localRequestHandler config + let localApp :: (Socket, SockAddr) -> IO () + localApp s = logSA "L loop" (pure s) - + \(_localSocket, _localAddr) -> do + _say "L : nyaa!" + + setSocketOption _localSocket ReuseAddr 1 + bindSocket _localSocket _localAddr - forever - handleLocal _localSocket + listen _localSocket 1 - let remoteApp :: (Socket, SockAddr) -> IO () - remoteApp s = logSA "R loop" (pure s) - - \(_remoteSocket, _remoteAddr) -> do - _say "Moe remote!" + let handleLocal _socket = do + (_newSocket, _) <- accept _socket + forkIO - catchExceptAsyncLog "L thread" - + logSocket "L client socket" (pure _newSocket) - + localRequestHandler _config + forever - handleLocal _localSocket + + let remoteApp :: (Socket, SockAddr) -> IO () + remoteApp s = logSA "R loop" (pure s) - + \(_remoteSocket, _remoteAddr) -> do + _say "R : nyaa!" + setSocketOption _remoteSocket ReuseAddr 1 bindSocket _remoteSocket _remoteAddr @@ -347,35 +371,30 @@ (_newSocket, _) <- accept _socket forkIO - catchExceptAsyncLog "R thread" - logSocket "R remote socket" (pure _newSocket) - - remoteRequestHandler config + remoteRequestHandler _config forever - handleRemote _remoteSocket - let - remoteRun :: IO () - remoteRun = do - let _c = config - getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream - >>= catchExceptAsyncLog "R app" . remoteApp - - localRun :: IO () - localRun = do - let _c = config - getSocket (_c ^. local . _Text) (_c ^. localPort) Stream - >>= catchExceptAsyncLog "L app" . localApp - - debugRun :: IO () - debugRun = do - catchExceptAsyncLog "Debug app" - do - {-puts "Waiting ..."-} - {-threadDelay 1000000 -- wait last instance terminate-} - {-puts "Done"-} - - runBoth localRun remoteRun + let + remoteRun :: IO () + remoteRun = do + let _c = _config + getSocket (_c ^. remote) (_c ^. remotePort) Stream + >>= catchExceptAsyncLog "R app" . remoteApp + + localRun :: IO () + localRun = do + let _c = _config + getSocket (_c ^. local) (_c ^. localPort) Stream + >>= catchExceptAsyncLog "L app" . localApp + debugRun :: IO () + debugRun = do + catchExceptAsyncLog "Debug app" - do + runBoth localRun remoteRun - case options ^. runningMode of - DebugMode -> debugRun - RemoteMode -> remoteRun - LocalMode -> localRun + io - case _options ^. runningMode of + DebugMode -> debugRun + RemoteMode -> remoteRun + LocalMode -> localRun 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 @@ -6,19 +6,19 @@ import Data.Attoparsec.ByteString import Data.Binary import Data.Binary.Put -import Data.Monoid import Data.Maybe +import Data.Monoid import Data.Text.Lens import Data.Text.Strict.Lens (utf8) -import Safe (readMay) import Network.MoeSocks.Constant import Network.MoeSocks.Helper import Network.MoeSocks.Type +import Network.Socket import Prelude hiding ((-), take) -import qualified Prelude as P +import Safe (readMay) import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B -import Network.Socket +import qualified Prelude as P socksVersion :: Word8 socksVersion = 5 @@ -182,13 +182,13 @@ _nameLength <- anyWord8 view utf8 <$> (take - fromIntegral _nameLength) - , IPv6_address <$> do - word8 4 - _a <- anyWord32be - _b <- anyWord32be - _c <- anyWord32be - _d <- anyWord32be - pure - (_a, _b, _c, _d) + {-, IPv6_address <$> do-} + {-word8 4 -} + {-_a <- anyWord32be-} + {-_b <- anyWord32be-} + {-_c <- anyWord32be-} + {-_d <- anyWord32be -} + {-pure - (_a, _b, _c, _d)-} ] 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 @@ -3,11 +3,12 @@ module Network.MoeSocks.Helper where -import Data.Attoparsec.ByteString import Control.Concurrent import Control.Exception import Control.Lens import Control.Monad +import Control.Monad.IO.Class +import Data.Attoparsec.ByteString import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString) @@ -20,12 +21,11 @@ import Network.Socket.ByteString import Prelude hiding (take, (-)) import System.IO.Unsafe (unsafePerformIO) +import System.Log.Logger import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LB -import System.Log.Logger - -- BEGIN backports infixr 0 - @@ -34,6 +34,9 @@ -- END backports +io :: (MonadIO m) => IO a -> m a +io = liftIO + flip4 :: (a, b, c, d) -> (d, c, b, a) flip4 (_a, _b, _c, _d) = (_d, _c, _b, _a) @@ -45,9 +48,9 @@ syncLock = unsafePerformIO - newEmptyMVar sync :: IO a -> IO a -sync io = do +sync aIO = do putMVar syncLock () - io <* takeMVar syncLock + aIO <* takeMVar syncLock puts :: String -> IO () puts = sync . debugM "moe" . ("😽 " <>) @@ -70,8 +73,9 @@ logClose :: String -> Socket -> IO () logClose aID aSocket = do - puts - "Closing socket " <> aID - close aSocket + pure aID + {-puts - "Closing socket " <> aID-} + close aSocket logSocketWithAddress :: String -> IO (Socket, SockAddr) -> ((Socket, SockAddr) -> IO a) -> IO a @@ -92,7 +96,7 @@ throw e catchExceptAsyncLog :: String -> IO a -> IO () -catchExceptAsyncLog aID io = catches (() <$ io) +catchExceptAsyncLog aID aIO = catches (() <$ aIO) [ Handler - \(e :: AsyncException) -> do pute - "ASyncException in " @@ -106,7 +110,7 @@ ] catchIO:: String -> IO a -> IO () -catchIO aID io = catch (() <$ io) - \e -> +catchIO aID aIO = catch (() <$ aIO) - \e -> pute - "Catch IO in " <> aID <> ": " <> show (e :: IOException) @@ -114,9 +118,9 @@ wrapIO :: (Maybe String, IO c) -> IO c wrapIO (s, _io) = do pure s - forM_ s - puts . ("+ " <>) + {-forM_ s - puts . ("+ " <>)-} _io - <* (forM_ s - puts . ("- " <>)) + {-<* (forM_ s - puts . ("- " <>))-} runBoth :: IO () -> IO () -> IO () runBoth x y = do @@ -157,15 +161,16 @@ handleError action -getSocket :: (Integral i, Show i) => HostName -> i -> SocketType -> +getSocket :: (Integral i, Show i) => Text -> i -> SocketType -> IO (Socket, SockAddr) getSocket aHost aPort aSocketType = do maybeAddrInfo <- firstOf folded <$> - getAddrInfo (Just hints) (Just aHost) (Just $ show aPort) + getAddrInfo (Just hints) + (Just - aHost ^. _Text) (Just - show aPort) case maybeAddrInfo of - Nothing -> error - "Error in getSocket for: " <> aHost <> ":" <> - show aPort + Nothing -> error - "Error in getSocket for: " <> aHost ^. _Text + <> ":" <> show aPort Just addrInfo -> do let family = addrFamily addrInfo let socketType = addrSocketType addrInfo @@ -174,7 +179,7 @@ _socket <- socket family socketType protocol - puts - "Getting socket: " <> show address + {-puts - "Getting socket: " <> show address-} pure (_socket, address) @@ -217,12 +222,12 @@ send_ :: Socket -> ByteString -> IO () send_ = sendAll -sendBuilder :: Socket -> B.Builder -> IO () -sendBuilder aSocket = send_ aSocket . builder_To_ByteString +sendBuilder :: Chan ByteString -> B.Builder -> IO () +sendBuilder _chan = writeChan _chan . builder_To_ByteString -sendBuilderEncrypted :: (ByteString -> IO ByteString) -> - Socket -> B.Builder -> IO () -sendBuilderEncrypted _encrypt aSocket x = send_ aSocket =<< +sendBuilderEncrypted :: Chan ByteString -> (ByteString -> IO ByteString) -> + B.Builder -> IO () +sendBuilderEncrypted _chan _encrypt x = writeChan _chan =<< _encrypt (builder_To_ByteString x) -- | An exception raised when parsing fails. @@ -233,21 +238,38 @@ instance Exception ParseException -parseSocket :: ByteString -> (ByteString -> IO ByteString) -> +parseSocket :: String -> ByteString -> (ByteString -> IO ByteString) -> Parser a -> Socket -> IO (ByteString, a) -parseSocket _left _decrypt aParser = parseSocketWith - parse aParser +parseSocket aID _partial _decrypt aParser = parseSocketWith aID - parse aParser where - parseSocketWith :: (ByteString -> Result a) -> + parseSocketWith :: String -> (ByteString -> Result a) -> Socket -> IO (ByteString, a) - parseSocketWith _parser _socket = do + parseSocketWith _id _parser _socket = do _rawBytes <- recv_ _socket {-puts - "rawBytes: " <> show _rawBytes-} _bytes <- _decrypt _rawBytes - let r = _parser - _left <> _bytes + let r = _parser - _partial <> _bytes case r of Done i _r -> pure (i, _r) Fail _ _ msg -> throwIO - ParseException - - "Failed to parse shadowSocksRequestParser: " - <> msg - Partial _p -> parseSocketWith _p _socket + "Failed to parse " <> _id <> ": " <> msg + Partial _p -> parseSocketWith _id _p _socket + +produceLoop :: Socket -> Chan ByteString -> + (ByteString -> IO ByteString) -> IO () +produceLoop aSocket aChan f = _produce + where + _produce = do + _r <- recv_ aSocket + if (_r & isn't _Empty) + then do + f _r >>= writeChan aChan + _produce + else do + {-puts - "0 bytes from remote!"-} + close aSocket + +consumeLoop :: Socket -> Chan ByteString -> IO () +consumeLoop aSocket aChan = + forever - readChan aChan >>= send_ aSocket 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 @@ -103,7 +103,7 @@ cipherMethod <- fmap fromJust $ withOpenSSL $ getCipherByName $ method ^. _Text - ctx <- cipherInitBS cipherMethod key cipher_iv Encrypt + ctx <- withOpenSSL $ cipherInitBS cipherMethod key cipher_iv Encrypt let encrypt buf = if S.null buf @@ -127,7 +127,8 @@ if empty then do let decipher_iv = S.take m1 buf - dctx <- cipherInitBS cipherMethod key decipher_iv Decrypt + dctx <- withOpenSSL $ + cipherInitBS cipherMethod key decipher_iv Decrypt putMVar decipherCtx $! dctx if S.null (S.drop m1 buf) then return "" 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 @@ -8,16 +8,16 @@ import Network.MoeSocks.Type import Options.Applicative hiding (Parser) import Prelude hiding ((-)) -import qualified Options.Applicative as O import System.Log.Logger +import qualified Options.Applicative as O optionParser :: O.Parser MoeOptions optionParser = let _mode = ( strOption - - short 'm' - <> long "mode" - <> metavar "MODE" - <> help "local | remote" + short 'm' + <> long "mode" + <> metavar "MODE" + <> help "local | remote" ) <|> pure "local" in let _config = ( strOption - @@ -34,7 +34,7 @@ short 'v' <> long "verbose" <> metavar "PRIORITY" - <> help "DEBUG|INFO|NOTICE|WARNING" + <> help "DEBUG|INFO|NOTICE" ) <|> pure INFO in let parseMode :: String -> RunningMode diff --git a/src/Network/MoeSocks/Type.hs b/src/Network/MoeSocks/Type.hs --- a/src/Network/MoeSocks/Type.hs +++ b/src/Network/MoeSocks/Type.hs @@ -4,6 +4,8 @@ module Network.MoeSocks.Type where import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader import Data.Aeson import Data.ByteString (ByteString) import Data.Text (Text) @@ -75,7 +77,16 @@ makeLenses ''MoeOptions +data Env = Env + { + _options :: MoeOptions + , _config :: MoeConfig + } + deriving (Show, Eq) +makeLenses ''Env + type Cipher = ByteString -> IO ByteString +type MoeMonadT = ReaderT MoeOptions (ExceptT String IO)