moesocks 0.1.2.0 → 0.1.2.10
raw patch · 13 files changed
+384/−314 lines, 13 files
Files
- CHANGELOG.md +4/−0
- README.md +3/−2
- moesocks.cabal +5/−3
- src/Network/MoeSocks/App.hs +66/−212
- src/Network/MoeSocks/BuilderAndParser.hs +15/−6
- src/Network/MoeSocks/Common.hs +20/−24
- src/Network/MoeSocks/Constant.hs +0/−24
- src/Network/MoeSocks/Helper.hs +13/−5
- src/Network/MoeSocks/Modules/Resource.hs +113/−0
- src/Network/MoeSocks/Runtime.hs +81/−0
- src/Network/MoeSocks/TCP.hs +5/−3
- src/Network/MoeSocks/Type.hs +57/−33
- src/Network/MoeSocks/UDP.hs +2/−2
CHANGELOG.md view
@@ -1,3 +1,7 @@+0.1.2.10+-------+* Fix not parsing snake case in config, a bug in introduced in 0.1.2.0+ 0.1.2.0 -------
README.md view
@@ -55,9 +55,10 @@ Drawbacks ========== -* UDP over SOCKS5 is not implemented+* UDP over SOCKS5 is not implemented. * More then 2 times slower then the original Python implementation (measured at- 20M/s vs 43M/s on an Intel P8800, using the AES-256-CFB method)+ 20M/s vs 43M/s on an Intel P8800, using the AES-256-CFB method).+* Currently only works on Linux. TCP Fast Open (TFO)
moesocks.cabal view
@@ -1,6 +1,6 @@ name: moesocks category: Network-version: 0.1.2.0+version: 0.1.2.10 license: Apache-2.0 synopsis: A functional firewall killer description: A SOCKS5 proxy using the client / server architecture.@@ -23,8 +23,9 @@ executable moesocks main-is: Main.hs- ghc-options: -Wall -fno-warn-unused-do-bind -O2+ ghc-options: -Wall -fno-warn-unused-do-bind -threaded+ ---O2 -- -rtsopts "-with-rtsopts=-N -c" build-depends: base > 4 && <= 5 , HsOpenSSL@@ -58,11 +59,12 @@ Network.MoeSocks.BuilderAndParser Network.MoeSocks.Common Network.MoeSocks.Config- Network.MoeSocks.Constant Network.MoeSocks.Encrypt Network.MoeSocks.Helper Network.MoeSocks.Internal.Socket+ Network.MoeSocks.Modules.Resource Network.MoeSocks.Options+ Network.MoeSocks.Runtime Network.MoeSocks.TCP Network.MoeSocks.Type Network.MoeSocks.UDP
src/Network/MoeSocks/App.hs view
@@ -4,40 +4,29 @@ module Network.MoeSocks.App where import Control.Concurrent+import Control.Concurrent.STM import Control.Concurrent.Async hiding (waitBoth) 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.Aeson.Lens import Data.ByteString (ByteString)-import Data.Maybe (fromMaybe)-import Data.Text (Text) import Data.Text.Lens-import Network.MoeSocks.Config-import Network.MoeSocks.Constant-import Network.MoeSocks.Encrypt (initCipherBox, safeMethods, unsafeMethods) import Network.MoeSocks.Common+import Network.MoeSocks.Encrypt (initCipherBox, safeMethods, unsafeMethods) import Network.MoeSocks.Helper+import Network.MoeSocks.Modules.Resource (loadConfig)+import Network.MoeSocks.Runtime import Network.MoeSocks.TCP import Network.MoeSocks.Type import Network.MoeSocks.UDP import Network.Socket hiding (send, recv, recvFrom, sendTo) import Network.Socket.ByteString import Prelude hiding ((-), take)-import System.Log.Formatter-import System.Log.Handler.Simple-import System.Log.Logger-import qualified Data.HashMap.Strict as H-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import qualified System.IO as IO-import qualified System.Log.Handler as LogHandler -+_PacketLength :: Int+_PacketLength = 4096 withGateOptions :: Options -> IO a -> IO () withGateOptions aOption aIO = do@@ -56,114 +45,7 @@ else () <$ aIO -parseConfig :: Options -> MoeMonadT Config-parseConfig aOption = do- let _maybeFilePath = aOption ^. configFile -- _v <- case _maybeFilePath of- Nothing -> pure - Just - Object mempty- Just _filePath -> fmap (preview _JSON) - - io - TIO.readFile - _filePath ^. _Text-- let -- asList :: ([(Text, Value)] -> [(Text, Value)]) -> Value -> Value- asList f = over _Object - H.fromList . f . H.toList - - fromShadowSocksConfig :: Text -> Text- fromShadowSocksConfig x = - let fixes = Map.fromList- [- ("server", "remoteAddress")- , ("server_port", "remotePort")- , ("local_address", "localAddress")- , ("local_port", "localPort")- ]-- in- fixes ^? ix x & fromMaybe x-- toParsableConfig :: Value -> Value- toParsableConfig = asList - each . _1 %~ (- T.cons '_' - {-. toHaskellNamingConvention-}- . fromShadowSocksConfig- ) -- toReadableConfig :: Value -> Value- toReadableConfig = asList - each . _1 %~ T.tail -- showConfig :: Config -> Text- showConfig = review _JSON- . toReadableConfig - . review _JSON -- filterEssentialConfig :: Value -> Value- filterEssentialConfig = over _Object - \_obj ->- foldl (flip H.delete) _obj - - [- "_password"- ]- - insertConfig :: Value -> Value -> Value- insertConfig (Object _from) = over _Object (_from `H.union`)- insertConfig _ = const Null-- insertParams :: [(Text, Value)] -> Value -> Value- insertParams _from = over _Object (H.fromList _from `H.union`)-- fallbackConfig :: Value -> Value -> Value- fallbackConfig = flip insertConfig-- optionalConfig = filterEssentialConfig - toJSON defaultConfig- - _maybeConfig = -- trace ("JSON: " <> show _v) - _v- >>= decode - . encode - . fallbackConfig optionalConfig- . insertParams (aOption ^. params)- . toParsableConfig -- case _maybeConfig of- Nothing -> do- let _r = - execWriter - do- tell "\n\n"- case _maybeFilePath of- Just _filePath -> do- tell "Failed to parse configuration file: "- tell _filePath- tell "\n"- tell "Example: \n"- tell - showConfig defaultConfig <> "\n"- Nothing -> do- tell "The password argument '-k' is required.\n"- tell "Alternatively, use '-c' to provide a "- tell "configuration file.\n"-- throwError - _r ^. _Text -- Just _config -> do- let configStr = showConfig _config ^. _Text :: String- io - debug_ - "Using config: " <> configStr- pure - _config --initLogger :: Priority -> IO ()-initLogger aLevel = do- stdoutHandler <- streamHandler IO.stdout DEBUG- let formattedHandler = - LogHandler.setFormatter stdoutHandler -- --"[$time : $loggername : $prio]- simpleLogFormatter "$time $prio\t $msg"-- updateGlobalLogger rootLoggerName removeHandler-- updateGlobalLogger "moe" removeHandler- updateGlobalLogger "moe" - addHandler formattedHandler- updateGlobalLogger "moe" - setLevel aLevel--data RelayType = TCP_Relay | UDP_Relay +data ServiceType = TCP_Service | UDP_Service deriving (Show, Eq) moeApp:: MoeMonadT ()@@ -173,7 +55,7 @@ io - debug_ - show _options - _config <- parseConfig - _options+ _config <- loadConfig - _options let _c = _config let _method = _config ^. method@@ -186,19 +68,19 @@ let _env = Env _options _config _cipherBox - let localRelay :: RelayType + let localService :: ServiceType -> String -> (ByteString -> (Socket, SockAddr) -> IO ()) -> (Socket, SockAddr) -> IO ()- localRelay aRelayType aID aHandler s = + localService aServiceType aID aHandler s = logSA "L loop" (pure s) - \(_localSocket, _localAddr) -> do setSocketOption _localSocket ReuseAddr 1 bindSocket _localSocket _localAddr - case aRelayType of- TCP_Relay -> do+ case aServiceType of+ TCP_Service -> do info_ - "LT: " <> aID <> " nyaa!" when (_c ^. fastOpen) -@@ -217,7 +99,7 @@ forever - handleLocal _localSocket - UDP_Relay -> do+ UDP_Service -> do info_ - "LU: " <> aID <> " nyaa!" let handleLocal = do (_msg, _sockAddr) <- @@ -237,7 +119,7 @@ showWrapped x = "[" <> show x <> "]" let local_SOCKS5 :: (Socket, SockAddr) -> IO ()- local_SOCKS5 _s = localRelay TCP_Relay + local_SOCKS5 _s = localService TCP_Service ("SOCKS5 proxy " <> showWrapped (_s ^. _2)) (local_SOCKS5_RequestHandler _env) - _s @@ -255,14 +137,14 @@ localForward_TCP :: Forward -> (Socket, SockAddr) -> IO () localForward_TCP _f _s = do let _m = showForwarding _f- localRelay TCP_Relay ("TCP port forwarding " <> _m)+ localService TCP_Service ("TCP port forwarding " <> _m) (local_TCP_ForwardRequestHandler _env _f) _s localForward_UDP :: Forward -> (Socket, SockAddr) -> IO () localForward_UDP _f _s = do let _m = showForwarding _f - localRelay UDP_Relay ("UDP port forwarding " <> _m)+ localService UDP_Service ("UDP port forwarding " <> _m) (local_UDP_ForwardRequestHandler _env _f) _s @@ -311,97 +193,69 @@ forever handleRemote - let runRemoteRelay :: RemoteRelay -> IO RemoteRelay + -- Run++ let runRemoteRelay :: RemoteRelay -> IO () runRemoteRelay _remoteRelay = do let _address = _remoteRelay ^. remoteRelayAddress _port = _remoteRelay ^. remoteRelayPort - _relay_ID <- fmap Relay_ID - async - foreverRun - do- case _remoteRelay ^. remoteRelayType of- Remote_TCP_Relay -> catchExceptAsyncLog "R TCP Relay" - do- getSocket _address _port Stream- >>= remote_TCP_Relay + case _remoteRelay ^. remoteRelayType of+ Remote_TCP_Relay -> catchExceptAsyncLog "R TCP Relay" - do+ getSocket _address _port Stream+ >>= remote_TCP_Relay - Remote_UDP_Relay -> catchExceptAsyncLog "R UDP Relay" - do- getSocket _address _port Datagram- >>= remote_UDP_Relay + Remote_UDP_Relay -> catchExceptAsyncLog "R UDP Relay" - do+ getSocket _address _port Datagram+ >>= remote_UDP_Relay - pure - _remoteRelay & relay_ID ?~ _relay_ID+ + let runLocalService :: LocalService -> IO ()+ runLocalService _localService = do+ case _localService ^. localServiceType of+ LocalService_TCP_Forward forwarding -> + catchExceptAsyncLog "L TCP_Forwarding" - do+ getSocket (_localService ^. localServiceAddress) + (forwarding ^. forwardLocalPort) + Stream+ >>= localForward_TCP forwarding+ + LocalService_UDP_Forward forwarding ->+ catchExceptAsyncLog "L UDP_Forwarding" - do+ getSocket (_localService ^. localServiceAddress) + (forwarding ^. forwardLocalPort) + Datagram+ >>= localForward_UDP forwarding+ + LocalService_SOCKS5 _port ->+ catchExceptAsyncLog "L SOCKS5" - do+ getSocket (_localService ^. localServiceAddress) _port Stream+ >>= local_SOCKS5 - let - runRemote :: IO ()- runRemote = do- let config_To_Runtime :: Config -> Runtime -> Runtime- config_To_Runtime _config _runtime = - let _remote_TCP_Relay = - RemoteRelay- Remote_TCP_Relay- (_config ^. remoteAddress)- (_config ^. remotePort)- Nothing+ runJob :: Job -> TVar JobStatus -> IO ()+ runJob (RemoteRelayJob x) _ = runRemoteRelay x+ runJob (LocalServiceJob x) _ = runLocalService x + + runApp :: [Job] -> IO ()+ runApp someJobs = do+ _jobs <- (forM someJobs - \_job -> (,) _job + <$> newTVarIO initialJobStatus)+ _asyncs <- mapM (async . foreverRun . (uncurry runJob)) _jobs + + _mainThread <- async - do+ waitAnyCancel - _asyncs - _remote_UDP_Relay = - RemoteRelay- Remote_UDP_Relay- (_config ^. remoteAddress)- (_config ^. remotePort)- Nothing - in- _runtime & remoteRelays .~ [_remote_TCP_Relay, _remote_UDP_Relay]- - relays <- mapM runRemoteRelay - - config_To_Runtime _c mempty ^. remoteRelays+ _uiThread <- async - forever - do+ let _statuses = _jobs ^.. each . _2 :: [TVar JobStatus]+ {-forM_ _statuses - readTVarIO >=> print-}+ sleep 5 - waitAnyCancel - relays ^.. each . relay_ID . _Just . unRelay_ID+ waitAnyCancel [_mainThread, _uiThread] pure ()-- - runLocal :: IO ()- runLocal = do- let _localForward_TCPs = do- forM_ (_options ^. forward_TCPs) - \forwarding -> forkIO - do- foreverRun - catchExceptAsyncLog "L TCP_Forwarding" - do- getSocket (_c ^. localAddress) - (forwarding ^. forwardLocalPort) - Stream- >>= localForward_TCP forwarding- - let _localForward_UDPs = do- forM_ (_options ^. forward_UDPs) - \forwarding -> forkIO - do- foreverRun - catchExceptAsyncLog "L UDP_Forwarding" - do- getSocket (_c ^. localAddress) - (forwarding ^. forwardLocalPort) - Datagram- >>= localForward_UDP forwarding- - let _local_SOCKS5 = foreverRun - catchExceptAsyncLog "L SOCKS5" - do- getSocket (_c ^. localAddress) (_c ^. localPort) Stream- >>= local_SOCKS5 - _localForward_TCPs- _localForward_UDPs- if (_options ^. disable_SOCKS5) - then - if (_options ^. forward_TCPs & isn't _Empty)- || (_options ^. forward_UDPs & isn't _Empty)- then - forever - sleep 1000- else- error_ "Nothing to run!"- - else _local_SOCKS5+ io - runApp - filterJobs (_options ^. runningMode) - loadJobs _c _options - runDebug :: IO ()- runDebug = do- catchExceptAsyncLog "runDebug" - do- waitBothDebug- (Just "runLocal", runLocal)- (Just "runRemote", runRemote) - io - case _options ^. runningMode of- DebugMode -> runDebug- RemoteMode -> runRemote- LocalMode -> runLocal
src/Network/MoeSocks/BuilderAndParser.hs view
@@ -10,7 +10,6 @@ import Data.Monoid import Data.Text.Lens import Data.Text.Strict.Lens (utf8)-import Network.MoeSocks.Constant import Network.MoeSocks.Helper import Network.MoeSocks.Type import Network.Socket@@ -19,14 +18,24 @@ import qualified Data.ByteString.Builder as B import qualified Prelude as P -{-import Debug.Trace-} -socksVersion :: Word8-socksVersion = 5 +_No_authentication :: Word8+_No_authentication = 0+ +_Request_Granted :: Word8+_Request_Granted = 0 +_ReservedByte :: Word8+_ReservedByte = 0 +_SpaceCode :: Word8+_SpaceCode = 32 ++socksVersion :: Word8+socksVersion = 5+ -- Builder greetingReplyBuilder :: B.Builder@@ -113,7 +122,7 @@ connectionType_To_Word8 :: ConnectionType -> Word8 connectionType_To_Word8 TCP_IP_StreamConnection = 1-connectionType_To_Word8 TCP_IP_PortBinding = 2+{-connectionType_To_Word8 TCP_IP_PortBinding = 2-} connectionType_To_Word8 UDP_Port = 3 @@ -161,7 +170,7 @@ __connectionType <- choice [ TCP_IP_StreamConnection <$ word8 1 - , TCP_IP_PortBinding <$ word8 2+ {-, TCP_IP_PortBinding <$ word8 2-} , UDP_Port <$ word8 3 ]
src/Network/MoeSocks/Common.hs view
@@ -7,38 +7,26 @@ import Control.Monad.Writer hiding (listen) import Data.IP import Data.Maybe-import Data.Text (Text) import Data.Text.Lens import Network.MoeSocks.Helper import Network.MoeSocks.Type import Network.Socket hiding (send, recv, recvFrom, sendTo) import Prelude hiding ((-), take)-import qualified Data.List as L -showAddressType :: AddressType -> Text-showAddressType (IPv4_Address xs) = xs ^.. each . to show- ^.. folding (concat . L.intersperse ".")- ^. from _Text- -showAddressType (DomainName x) = x -showAddressType (IPv6_Address xs) = xs ^.. each . to show- ^.. folding (concat . L.intersperse ":")- ^. from _Text - makePrisms ''IPRange checkForbidden_IP_List :: AddressType -> [IPRange] -> Bool checkForbidden_IP_List _address@(IPv4_Address _) aForbidden_IP_List = isJust - do- _ip <- showAddressType _address ^. _Text ^? _Show+ _ip <- show _address ^? _Show findOf (each . _IPv4Range) (isMatchedTo _ip) aForbidden_IP_List checkForbidden_IP_List _address@(IPv6_Address _) aForbidden_IP_List = isJust - do- _ip <- showAddressType _address ^. _Text ^? _Show+ _ip <- show _address ^? _Show findOf (each . _IPv6Range) (isMatchedTo _ip) aForbidden_IP_List checkForbidden_IP_List _ _ = False@@ -46,19 +34,19 @@ withCheckedForbidden_IP_List :: AddressType -> [IPRange] -> IO a -> IO () withCheckedForbidden_IP_List aAddressType aForbidden_IP_List aIO = if checkForbidden_IP_List aAddressType aForbidden_IP_List - then error_ - showAddressType aAddressType ^. _Text + then error_ - show aAddressType <> " is in forbidden-ip list" else () <$ aIO showConnectionType :: ConnectionType -> String showConnectionType TCP_IP_StreamConnection = "TCP_Stream"-showConnectionType TCP_IP_PortBinding = "TCP_Bind "+-- showConnectionType TCP_IP_PortBinding = "TCP_Bind " showConnectionType UDP_Port = "UDP " showRequest :: ClientRequest -> String showRequest _r = - _r ^. addressType . to showAddressType . _Text+ _r ^. addressType . to show <> ":" <> _r ^. portNumber . to show @@ -71,17 +59,25 @@ addressType_To_Family (IPv6_Address _) = Just AF_INET6 addressType_To_Family _ = Nothing -connectionType_To_SocketType :: ConnectionType -> SocketType-connectionType_To_SocketType TCP_IP_StreamConnection = Stream-connectionType_To_SocketType TCP_IP_PortBinding = NoSocketType-connectionType_To_SocketType UDP_Port = Datagram+_SocketType :: Prism' SocketType ConnectionType+_SocketType = prism' connectionType_To_SocketType socketType_To_connectionType+ where+ connectionType_To_SocketType :: ConnectionType -> SocketType+ connectionType_To_SocketType TCP_IP_StreamConnection = Stream+ {-connectionType_To_SocketType TCP_IP_PortBinding = NoSocketType-}+ connectionType_To_SocketType UDP_Port = Datagram + socketType_To_connectionType :: SocketType -> Maybe ConnectionType+ socketType_To_connectionType Stream = Just TCP_IP_StreamConnection+ socketType_To_connectionType Datagram = Just UDP_Port+ socketType_To_connectionType _ = Nothing++ initTarget :: ClientRequest -> IO (Socket, SockAddr) initTarget _clientRequest = do let- _socketType = _clientRequest ^. - connectionType . to connectionType_To_SocketType- _hostName = _clientRequest ^. addressType . to showAddressType+ _socketType = _clientRequest ^. connectionType . re _SocketType+ _hostName = _clientRequest ^. addressType . to show . from _Text _port = _clientRequest ^. portNumber _family = _clientRequest ^. addressType . to addressType_To_Family
− src/Network/MoeSocks/Constant.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.MoeSocks.Constant where--import Data.Word--_No_authentication :: Word8-_No_authentication = 0- -_Request_Granted :: Word8-_Request_Granted = 0--_ReservedByte :: Word8-_ReservedByte = 0--_SpaceCode :: Word8-_SpaceCode = 32--_PacketLength :: Int-_PacketLength = 4096---_NoThrottle :: Maybe a-_NoThrottle = Nothing
src/Network/MoeSocks/Helper.hs view
@@ -14,6 +14,7 @@ import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString)+import Data.Char (isUpper) import Data.Maybe import Data.Monoid import Data.Text (Text)@@ -32,6 +33,7 @@ import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LB import qualified Data.Strict as S+import qualified Data.Text as T -- BEGIN backports @@ -42,6 +44,8 @@ -- END backports +is :: APrism s t a b -> s -> Bool+is x = not . isn't x type HCipher = S.Maybe ByteString -> IO ByteString type HQueue = TBQueue (S.Maybe ByteString)@@ -446,8 +450,12 @@ tryIO :: String -> IO a -> IO (Either IOException a) tryIO _ = try -- . logException aID -{-toHaskellNamingConvention :: Text -> Text-}-{-toHaskellNamingConvention x = x -}- {-& T.split (`elem` ['_', '-'])-}- {-& over (_tail . traversed) T.toTitle-}- {-& T.concat-}+toHaskellNamingConvention :: Text -> Text+toHaskellNamingConvention x = + let xs = x & T.split (`elem` ['_', '-'])+ in+ if xs & anyOf each (T.all isUpper)+ then x+ else xs+ & over (_tail . traversed) T.toTitle+ & T.concat
+ src/Network/MoeSocks/Modules/Resource.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Network.MoeSocks.Modules.Resource where++import Control.Lens+import Control.Monad+import Control.Monad.Except+import Control.Monad.Writer hiding (listen)+import Data.Aeson hiding (Result)+import Data.Aeson.Lens+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Lens+import Network.MoeSocks.Config+import Network.MoeSocks.Helper+import Network.MoeSocks.Type+import Prelude hiding ((-), take)+import qualified Data.HashMap.Strict as H+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++loadConfig :: Options -> MoeMonadT Config+loadConfig aOption = do+ let _maybeFilePath = aOption ^. configFile ++ _v <- case _maybeFilePath of+ Nothing -> pure - Just - Object mempty+ Just _filePath -> fmap (preview _JSON) - + io - TIO.readFile - _filePath ^. _Text++ let ++ asList :: ([(Text, Value)] -> [(Text, Value)]) -> Value -> Value+ asList f = over _Object - H.fromList . f . H.toList + + fromShadowSocksConfig :: Text -> Text+ fromShadowSocksConfig x = + let fixes = Map.fromList+ [+ ("server", "remoteAddress")+ , ("server_port", "remotePort")+ ]++ in+ fixes ^? ix x & fromMaybe x++ toParsableConfig :: Value -> Value+ toParsableConfig = asList - each . _1 %~ (+ T.cons '_' + . toHaskellNamingConvention+ . fromShadowSocksConfig+ ) ++ toReadableConfig :: Value -> Value+ toReadableConfig = asList - each . _1 %~ T.tail ++ showConfig :: Config -> Text+ showConfig = review _JSON+ . toReadableConfig + . review _JSON ++ filterEssentialConfig :: Value -> Value+ filterEssentialConfig = over _Object - \_obj ->+ foldl (flip H.delete) _obj - + [+ "_password"+ ]+ + insertConfig :: Value -> Value -> Value+ insertConfig (Object _from) = over _Object (_from `H.union`)+ insertConfig _ = const Null++ insertParams :: [(Text, Value)] -> Value -> Value+ insertParams _from = over _Object (H.fromList _from `H.union`)++ fallbackConfig :: Value -> Value -> Value+ fallbackConfig = flip insertConfig++ optionalConfig = filterEssentialConfig - toJSON defaultConfig+ + _maybeConfig = -- trace ("JSON: " <> show _v) + _v+ >>= decode + . encode + . fallbackConfig optionalConfig+ . insertParams (aOption ^. params)+ . toParsableConfig ++ case _maybeConfig of+ Nothing -> do+ let _r = + execWriter - do+ tell "\n\n"+ case _maybeFilePath of+ Just _filePath -> do+ tell "Failed to parse configuration file: "+ tell _filePath+ tell "\n"+ tell "Example: \n"+ tell - showConfig defaultConfig <> "\n"+ Nothing -> do+ tell "The password argument '-k' is required.\n"+ tell "Alternatively, use '-c' to provide a "+ tell "configuration file.\n"++ throwError - _r ^. _Text ++ Just _config -> do+ let configStr = showConfig _config ^. _Text :: String+ io - debug_ - "Using config: " <> configStr+ pure - _config
+ src/Network/MoeSocks/Runtime.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Network.MoeSocks.Runtime where++import Control.Lens+import Control.Monad.Writer hiding (listen)+import Network.MoeSocks.Helper+import Network.MoeSocks.Type+import Prelude hiding ((-), take)+import System.Log.Formatter+import System.Log.Handler.Simple+import System.Log.Logger+import qualified System.IO as IO+import qualified System.Log.Handler as LogHandler++++initLogger :: Priority -> IO ()+initLogger aLevel = do+ stdoutHandler <- streamHandler IO.stdout DEBUG+ let formattedHandler = + LogHandler.setFormatter stdoutHandler -+ --"[$time : $loggername : $prio]+ simpleLogFormatter "$time $prio\t $msg"++ updateGlobalLogger rootLoggerName removeHandler++ updateGlobalLogger "moe" removeHandler+ updateGlobalLogger "moe" - addHandler formattedHandler+ updateGlobalLogger "moe" - setLevel aLevel+++loadJobs :: Config -> Options -> [Job]+loadJobs aConfig aOptions = + let _c = aConfig++ _remote_TCP_Relay = + RemoteRelay+ Remote_TCP_Relay+ (_c ^. remoteAddress)+ (_c ^. remotePort)++ _remote_UDP_Relay = + RemoteRelay+ Remote_UDP_Relay+ (_c ^. remoteAddress)+ (_c ^. remotePort)++ _localService :: LocalServiceType -> LocalService+ _localService = LocalService + (_c ^. localAddress)+ (_c ^. remoteAddress)+ (_c ^. remotePort)++ _localService_TCP_Forwards = + aOptions ^. forward_TCPs + & map (_localService . LocalService_TCP_Forward)++ _localService_UDP_Forwards =+ aOptions ^. forward_UDPs + & map (_localService . LocalService_UDP_Forward)++ _localService_SOCKS5 =+ LocalService_SOCKS5 (_c ^. localPort)+ & _localService++ _remoteRelays = [_remote_TCP_Relay, _remote_UDP_Relay]+ _localServices = _localService_TCP_Forwards+ <> _localService_UDP_Forwards+ <> pure _localService_SOCKS5+ in++ map RemoteRelayJob _remoteRelays+ <> map LocalServiceJob _localServices++filterJobs :: RunningMode -> [Job] -> [Job]+filterJobs = \case+ DebugMode -> id+ RemoteMode -> filter - is _RemoteRelayJob+ LocalMode -> filter - is _LocalServiceJob
src/Network/MoeSocks/TCP.hs view
@@ -10,7 +10,6 @@ import Data.ByteString (ByteString) import Network.MoeSocks.BuilderAndParser import Network.MoeSocks.Common-import Network.MoeSocks.Constant import Network.MoeSocks.Encrypt (identityCipher) import Network.MoeSocks.Helper import Network.MoeSocks.Type@@ -20,6 +19,9 @@ import qualified Data.ByteString as S import qualified Data.Strict as S +_NoThrottle :: Maybe a+_NoThrottle = Nothing+ local_SOCKS5_RequestHandler :: Env -> ByteString -> (Socket, SockAddr) @@ -55,8 +57,8 @@ let _clientRequest = ClientRequest TCP_IP_StreamConnection (DomainName - aForwarding ^. - forwardRemoteHost)- (aForwarding ^. forwardRemotePort)+ forwardTargetAddress)+ (aForwarding ^. forwardTargetPort) local_TCP_RequestHandler aEnv (mempty, _clientRequest) False aSocket
src/Network/MoeSocks/Type.hs view
@@ -7,15 +7,17 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Concurrent.Async+import Control.Concurrent.STM import Data.Aeson import Data.ByteString (ByteString) import Data.Text (Text)+import Data.Text.Lens import Data.IP import Data.Word-import Data.Monoid-import GHC.Generics+import GHC.Generics (Generic) import System.Log.Logger import qualified Data.Strict as S+import qualified Data.List as L data ClientGreeting = ClientGreeting {@@ -27,7 +29,7 @@ data ConnectionType = TCP_IP_StreamConnection- | TCP_IP_PortBinding+-- | TCP_IP_PortBinding | UDP_Port deriving (Show, Eq) @@ -35,8 +37,20 @@ IPv4_Address (Word8, Word8, Word8, Word8) | DomainName Text | IPv6_Address [Word16]- deriving (Show, Eq)+ deriving (Eq) +instance Show AddressType where+ show = showAddressType+ where+ showAddressType :: AddressType -> String+ showAddressType (IPv4_Address xs) = xs ^.. each . to show+ ^.. folding + (concat . L.intersperse ".")+ + showAddressType (DomainName x) = x ^. _Text+ showAddressType (IPv6_Address xs) = xs ^.. each . to show+ ^.. folding + (concat . L.intersperse ":") type Port = Int data ClientRequest = ClientRequest@@ -82,8 +96,8 @@ data Forward = Forward { _forwardLocalPort :: Port- , _forwardRemoteHost :: Text- , _forwardRemotePort :: Port+ , _forwardTargetAddress :: Text+ , _forwardTargetPort :: Port } deriving (Show, Eq) @@ -127,24 +141,25 @@ makeLenses ''CipherBox -data LocalRelayType =- Local_TCP_Relay Forward- | Local_UDP_Relay Forward- | Local_SOCKS_Relay Int+data LocalServiceType =+ LocalService_TCP_Forward Forward+ | LocalService_UDP_Forward Forward+ | LocalService_SOCKS5 Int deriving (Show, Eq) -makePrisms ''LocalRelayType+makePrisms ''LocalServiceType -data LocalRelay = LocalRelay++data LocalService = LocalService {- _localRelayType :: LocalRelayType- , _localRelayAddress :: Text- , _localRelayRemoteAddress :: Text- , _localRelayRemotePort :: Int+ _localServiceAddress :: Text+ , _localServiceRemoteAddress :: Text+ , _localServiceRemotePort :: Int+ , _localServiceType :: LocalServiceType } deriving (Show, Eq) -makeLenses ''LocalRelay+makeLenses ''LocalService data RemoteRelayType = Remote_TCP_Relay@@ -153,38 +168,47 @@ makePrisms ''RemoteRelayType -newtype Relay_ID = Relay_ID { _unRelay_ID :: Async () }- deriving (Eq, Ord) -makeLenses ''Relay_ID--instance Show Relay_ID where- show _ = "Relay ID"- data RemoteRelay = RemoteRelay { _remoteRelayType :: RemoteRelayType , _remoteRelayAddress :: Text , _remoteRelayPort :: Int- , _relay_ID :: Maybe Relay_ID } deriving (Show, Eq) makeLenses ''RemoteRelay +data Job = + RemoteRelayJob RemoteRelay+ | LocalServiceJob LocalService+ deriving (Show, Eq)++makePrisms ''Job++type Async_ID = Async ()++data JobStatus = JobStatus+ {+ _incomingSpeed :: Double+ , _incomingTotal :: Double+ , _outgoingSpeed :: Double+ , _outgoingTotal :: Double+ , _numberOfRequests :: Int+ }+ deriving (Show, Eq)++makeLenses ''JobStatus++initialJobStatus :: JobStatus+initialJobStatus = JobStatus 0 0 0 0 0+ data Runtime = Runtime {- _localRelays :: [LocalRelay]- , _remoteRelays :: [RemoteRelay]+ _jobs :: [(Job, Async_ID, TVar JobStatus)] }- deriving (Show, Eq) makeLenses ''Runtime--instance Monoid Runtime where- mempty = Runtime [] []- Runtime x y `mappend` Runtime x' y' = Runtime (x <> x') (y <> y')- data Env = Env {
src/Network/MoeSocks/UDP.hs view
@@ -53,8 +53,8 @@ let _clientRequest = ClientRequest UDP_Port (DomainName - aForwarding ^. - forwardRemoteHost)- (aForwarding ^. forwardRemotePort)+ forwardTargetAddress)+ (aForwarding ^. forwardTargetPort) {-debug_ - "L UDP: " <> show _clientRequest-}