moesocks 0.1.0.6 → 0.1.0.7
raw patch · 8 files changed
+255/−191 lines, 8 filesdep +mtl
Dependencies added: mtl
Files
- moesocks.cabal +3/−2
- src/Main.hs +11/−1
- src/Network/MoeSocks/App.hs +159/−140
- src/Network/MoeSocks/BuilderAndParser.hs +11/−11
- src/Network/MoeSocks/Helper.hs +51/−29
- src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs +3/−2
- src/Network/MoeSocks/Options.hs +6/−6
- src/Network/MoeSocks/Type.hs +11/−0
moesocks.cabal view
@@ -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
src/Main.hs view
@@ -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 ()
src/Network/MoeSocks/App.hs view
@@ -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
src/Network/MoeSocks/BuilderAndParser.hs view
@@ -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)-} ]
src/Network/MoeSocks/Helper.hs view
@@ -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
src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs view
@@ -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 ""
src/Network/MoeSocks/Options.hs view
@@ -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
src/Network/MoeSocks/Type.hs view
@@ -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)