diff --git a/config.json b/config.json --- a/config.json +++ b/config.json @@ -1,8 +1,9 @@ { - "remote":"127.0.0.1", - "remotePort":1190, - "local":"127.0.0.1", - "localPort":1090, - "password":"birthday!" + "server":"127.0.0.1", + "server_port":1190, + "local_address":"localhost", + "local_port":1090, + "password":"birthday!", + "method":"aes-256-cfb" } 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.0 +version: 0.1.0.1 license: Apache-2.0 synopsis: moe for all description: A socks5 proxy server @@ -24,7 +24,7 @@ executable moesocks main-is: Main.hs - ghc-options: -Wall -fno-warn-unused-do-bind + ghc-options: -Wall -fno-warn-unused-do-bind -threaded build-depends: base > 4 && <= 5 , lens , network @@ -35,19 +35,22 @@ , attoparsec , text , random - , cipher-aes , optparse-applicative , aeson , unordered-containers , transformers + , HsOpenSSL + , containers + , cryptohash hs-source-dirs: src default-language: Haskell2010 other-modules: Network.MoeSocks.App - Network.MoeSocks.Config - Network.MoeSocks.Helper - Network.MoeSocks.Type Network.MoeSocks.BuilderAndParser + Network.MoeSocks.Config Network.MoeSocks.Constant + Network.MoeSocks.Helper + Network.MoeSocks.Internal.ShadowSocks.Encrypt Network.MoeSocks.OptionParser + Network.MoeSocks.Type diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} - module Main where import Network.MoeSocks.App 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 @@ -1,13 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE DeriveGeneric #-} module Network.MoeSocks.App where -import "cipher-aes" Crypto.Cipher.AES import Control.Concurrent -import Control.Exception import Control.Lens import Control.Monad import Data.Aeson @@ -15,7 +11,6 @@ import Data.Monoid import Data.Text (Text) import Data.Text.Lens -import Data.Word import Network.MoeSocks.BuilderAndParser import Network.MoeSocks.Config import Network.MoeSocks.Constant @@ -24,9 +19,7 @@ import Network.Socket import Prelude hiding ((-), take) import System.IO.Streams.Attoparsec -import System.IO.Streams.ByteString import System.IO.Streams.Network -import System.Random import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B import qualified Data.HashMap.Strict as H @@ -34,36 +27,18 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Text.Strict.Lens as TS -import qualified Prelude as P import qualified System.IO.Streams as Stream -addressType_To_SockAddr :: ClientRequest -> SockAddr -addressType_To_SockAddr aClientRequest = - let portNumber16 = fromWord8 - toListOf both - (aClientRequest ^. portNumber) :: Word16 - in - case aClientRequest ^. addressType of - IPv4_address _address -> SockAddrInet - (fromIntegral portNumber16) - (fromWord8 - reverse _address) - Domain_name x -> SockAddrUnix - x ^. TS.utf8 . _Text - IPv6_address xs -> - let rs = reverse - xs - in - SockAddrInet6 - (fromIntegral portNumber16) - 0 - ( fromWord8 - P.take 4 - rs - , fromWord8 - P.drop 4 - P.take 4 - rs - , fromWord8 - P.drop 8 - P.take 4 - rs - , fromWord8 - P.drop 12 - rs - ) - 0 - +showAddressType :: AddressType -> String +showAddressType (IPv4_address xs) = concat - L.intersperse "." - map show xs +showAddressType (Domain_name x) = view _Text - x ^. TS.utf8 +showAddressType x = error - + "IPv6 target not supported:" + <> show x -localRequestHandler:: MoeConfig -> (Socket, SockAddr) -> IO () -localRequestHandler config (_s, _) = withSocket _s - \aSocket -> do +localRequestHandler:: MoeConfig -> Socket -> IO () +localRequestHandler aConfig aSocket = do (inputStream, outputStream) <- socketToStreams aSocket let socksVersion = 5 @@ -81,205 +56,180 @@ socksHeader requestParser - tryParse - do - r <- parseFromStream greetingParser inputStream - if not - _No_authentication `elem` (r ^. authenticationMethods) - then do - close aSocket + r <- parseFromStream greetingParser inputStream + {-puts - "greetings: " <> show r-} - else do - pushStream outputStream - B.word8 socksVersion - <> B.word8 _No_authentication + forM_ (boolToMaybe - + _No_authentication `elem` (r ^. authenticationMethods)) - const - + do + pushStream outputStream - B.word8 socksVersion + <> B.word8 _No_authentication - _clientRequest <- parseFromStream connectionParser inputStream + _clientRequest <- parseFromStream connectionParser inputStream + {-puts - "request: " <> show _clientRequest-} - let conn = _clientRequest + let conn = _clientRequest - _remoteSocket <- socket AF_INET Stream defaultProtocol - - withSocket _remoteSocket - \_remoteSocket -> do - let _c = config - tryAddr (_c ^. remote) (_c ^. remotePort) - \_remoteAddr -> do - connect _remoteSocket _remoteAddr + let + _c = aConfig + _initSocket = + getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream + + logSA "Connect remote" _initSocket - \(_remoteSocket, _remoteAddress) -> do + connect _remoteSocket _remoteAddress - _localPeerAddr <- getPeerName aSocket - {-_localSocketAddr <- getSocketName aSocket-} - {-_remotePeerAddr <- getPeerName _remoteSocket-} - {-_remoteSocketAddr <- getSocketName _remoteSocket-} - let _clientAddr = addressType_To_SockAddr _clientRequest + _localPeerAddr <- getPeerName aSocket - puts - "L: " <> - ( - concat - L.intersperse " -> " - map show - [ - _localPeerAddr - {-, _localSocketAddr-} - {-, _remotePeerAddr-} - {-, _remoteSocketAddr-} - , _clientAddr - ] - ) + let showRequest :: ClientRequest -> String + showRequest _r = + showAddressType (_r ^. addressType) + <> ":" + <> show (_r ^. portNumber . to portNumber16) + puts - "L: " <> + ( + concat - L.intersperse " -> " + [ + show _localPeerAddr + , showRequest _clientRequest + ] + ) - let handleLocal _remoteSocket = do - let - write x = Stream.write (Just - x) outputStream - push = write . S.singleton + let handleLocal __remoteSocket = do + let + write x = Stream.write (Just - x) outputStream + push = write . S.singleton - push socksVersion - push _Request_Granted - push _ReservedByte + push socksVersion + push _Request_Granted + push _ReservedByte - write - builder_To_ByteString - - addressTypeBuilder (conn ^. addressType) + write - builder_To_ByteString - + addressTypeBuilder (conn ^. addressType) - traverseOf both push - conn ^. portNumber + traverseOf both push - conn ^. portNumber - (remoteInputStream, remoteOutputStream) <- - socketToStreams _remoteSocket + (remoteInputStream, remoteOutputStream) <- + socketToStreams _remoteSocket - _stdGen <- newStdGen + (_encrypt, _decrypt) <- getCipher + _DefaultMethod + (aConfig ^. password) - let _iv = S.pack - P.take _BlockSize - randoms _stdGen - - pushStream remoteOutputStream - B.byteString _iv - - let - _aesKey = aesKey config - _encrypt = encryptCTR _aesKey _iv - _decrypt = decryptCTR _aesKey _iv - - let - _header = requestBuilder conn - _headerBlock = clamp _PacketSize - - builder_To_ByteString _header - - pushStream remoteOutputStream - B.byteString - - _encrypt _headerBlock - - inputBlockStream <- tokenizeStream _PacketSize - _encrypt inputStream - - remoteInputBlockStream <- detokenizeStream _PacketSize - _decrypt remoteInputStream + let + _header = shadowsocksRequestBuilder conn + + remoteOutputEncryptedStream <- + Stream.contramapM _encrypt remoteOutputStream + + pushStream remoteOutputEncryptedStream - + B.byteString - builder_To_ByteString _header + + remoteInputDecryptedStream <- + Stream.mapM _decrypt remoteInputStream - waitBoth - (Stream.connect inputBlockStream remoteOutputStream) - (Stream.connect remoteInputBlockStream outputStream) - + waitBoth + (Stream.connect inputStream remoteOutputEncryptedStream) + (Stream.connect remoteInputDecryptedStream outputStream) + - safeSocketHandler "Local Request Handler" - handleLocal _remoteSocket + handleLocal _remoteSocket -remoteRequestHandler:: MoeConfig -> (Socket, SockAddr) -> IO () -remoteRequestHandler aConfig (_s, _) = withSocket _s - \aSocket -> do +remoteRequestHandler:: MoeConfig -> Socket -> IO () +remoteRequestHandler aConfig aSocket = do (remoteInputStream, remoteOutputStream) <- socketToStreams aSocket - tryParse - do - _iv <- parseFromStream (take _BlockSize) remoteInputStream - - let - _aesKey = aesKey aConfig - _encrypt = encryptCTR _aesKey _iv - _decrypt = decryptCTR _aesKey _iv - - _headerBlock <- _decrypt <$> readExactly (fromIntegral _PacketSize) - remoteInputStream - - _clientRequest <- - case eitherResult - parse requestParser _headerBlock of - Left err -> throwIO - ParseException err - Right r -> pure r - + (_encrypt, _decrypt) <- getCipher + _DefaultMethod + (aConfig ^. password) + + remoteInputDecryptedStream <- Stream.mapM _decrypt remoteInputStream + + _clientRequest <- parseFromStream + shadowsocksRequestParser remoteInputDecryptedStream - let - connectTarget :: ClientRequest -> IO (Maybe Socket) - connectTarget _clientRequest = do - let _socketAddr = addressType_To_SockAddr _clientRequest - - connectionType_To_SocketType :: ConnectionType -> SocketType - connectionType_To_SocketType TCP_IP_stream_connection = Stream - connectionType_To_SocketType TCP_IP_port_binding = NoSocketType - connectionType_To_SocketType UDP_port = Datagram - - _socketType = connectionType_To_SocketType - - _clientRequest ^. connectionType + {- + -puts - "Remote get: " <> show _clientRequest + -} + + let + initTarget :: ClientRequest -> IO (Socket, SockAddr) + initTarget _clientRequest = do + let + connectionType_To_SocketType :: ConnectionType -> SocketType + connectionType_To_SocketType TCP_IP_stream_connection = Stream + connectionType_To_SocketType TCP_IP_port_binding = NoSocketType + connectionType_To_SocketType UDP_port = Datagram + + _socketType = connectionType_To_SocketType - + _clientRequest ^. connectionType - let hints = defaultHints - { - addrSocketType = _socketType - } - - _hostName = sockAddr_To_Host _socketAddr - _port = sockAddr_To_Port _socketAddr - - _addrInfoList <- getAddrInfo - (Just hints) - (Just - _hostName) - (Just - _port) + _hostName = _clientRequest ^. addressType . to showAddressType + _port = _clientRequest ^. portNumber - let _maybeAddrInfo = preview traverse - - _addrInfoList - - case _maybeAddrInfo of - Nothing -> return Nothing - Just _addrInfo -> do - _targetSocket <- initSocketForType - (addrAddress _addrInfo) - (addrSocketType _addrInfo) + + getSocket _hostName (portNumber16 _port) _socketType - connect _targetSocket - addrAddress _addrInfo + logSocketWithAddress "Connect target" (initTarget _clientRequest) - \_r -> do + let (_targetSocket, _targetSocketAddress) = _r - pure - Just _targetSocket + connect _targetSocket _targetSocketAddress - _targetSocket <- connectTarget _clientRequest - - forM_ _targetSocket - flip withSocket - \_targetSocket -> do - _remotePeerAddr <- getPeerName aSocket - {-_remoteSocketAddr <- getSocketName aSocket-} - _targetPeerAddr <- getPeerName _targetSocket - {-_targetSocketAddr <- getSocketName _targetSocket-} + _remotePeerAddr <- getPeerName aSocket + _targetPeerAddr <- getPeerName _targetSocket - puts - "R: " <> - ( - concat - L.intersperse " -> " - map show - [ - _remotePeerAddr - {-, _remoteSocketAddr-} - , _targetPeerAddr - {-, _targetSocketAddr-} - ] - ) - let - handleTarget _targetSocket = do - (targetInputStream, targetOutputStream) <- - socketToStreams _targetSocket + puts - "R: " <> + ( + concat - L.intersperse " -> " - map show + [ + _remotePeerAddr + , _targetPeerAddr + ] + ) + let + handleTarget __targetSocket = do + (targetInputStream, targetOutputStream) <- + socketToStreams _targetSocket - targetInputBlockStream <- tokenizeStream _PacketSize - _encrypt targetInputStream - - remoteInputBlockStream <- detokenizeStream _PacketSize - _decrypt remoteInputStream + remoteOutputEncryptedStream <- + Stream.contramapM _encrypt remoteOutputStream - waitBoth - (Stream.connect remoteInputBlockStream targetOutputStream) - (Stream.connect targetInputBlockStream remoteOutputStream) - - safeSocketHandler "Target Connection Handler" - handleTarget _targetSocket + waitBoth + (Stream.connect remoteInputDecryptedStream targetOutputStream) + (Stream.connect targetInputStream remoteOutputEncryptedStream) + + handleTarget _targetSocket parseConfig :: Text -> IO (Maybe MoeConfig) parseConfig aConfigFile = do _configFile <- TIO.readFile - aConfigFile ^. _Text + let + + fromShadowSocksConfig :: [(Text, Value)] -> [(Text, Value)] + fromShadowSocksConfig _configList = + let fixes = + [ + ("server", "remote") + , ("server_port", "remotePort") + , ("local_address", "local") + , ("local_port", "localPort") + ] + + in + foldl (flip duplicateKey) _configList fixes + + fromSS :: [(Text, Value)] -> [(Text, Value)] + fromSS = fromShadowSocksConfig + let _v = decodeStrict - review TS.utf8 _configFile :: Maybe Value let fixConfig :: Value -> Value fixConfig (Object _obj) = Object - - _obj & H.toList & over (mapped . _1) (T.cons '_') & H.fromList + _obj & H.toList & fromSS & over (mapped . _1) (T.cons '_') & H.fromList fixConfig _ = Null let _maybeConfig = (_v >>= decode . encode . fixConfig) @@ -299,85 +249,62 @@ maybeConfig <- parseConfig - options ^. configFile forM_ maybeConfig - \config -> do - let localApp :: SockAddr -> IO (Socket, Socket -> IO ()) - localApp _localAddr = do - putStrLn "Moe local!" - - localSocket <- initSocket _localAddr - setSocketOption localSocket ReuseAddr 1 - bindSocket localSocket _localAddr + let localApp :: (Socket, SockAddr) -> IO () + localApp s = logSA "Local loop" (pure s) - + \(_localSocket, _localAddr) -> do + putStrLn "Moe local!" + + setSocketOption _localSocket ReuseAddr 1 + bindSocket _localSocket _localAddr - listen localSocket 1 + listen _localSocket 1 - let handleLocal _socket = do - r@(_newSocket, _newSocketAddr) <- accept _socket - forkIO - catchAll - onException - (localRequestHandler config r) - do - pute "local onException" - close _newSocket - localLoop = - forever . - safeSocketHandler "Local Connection" handleLocal + let handleLocal _socket = do + (_newSocket, _) <- accept _socket + forkIO - catchAll - + logSocket "Local handler" (pure _newSocket) - + localRequestHandler config - pure (localSocket, localLoop) + forever - handleLocal _localSocket - let remoteApp :: SockAddr -> IO (Socket, Socket -> IO ()) - remoteApp _remoteAddr = do + let remoteApp :: (Socket, SockAddr) -> IO () + remoteApp s = logSA "Remote loop" (pure s) - + \(_remoteSocket, _remoteAddr) -> do putStrLn "Moe remote!" - remoteSocket <- initSocket _remoteAddr - setSocketOption remoteSocket ReuseAddr 1 - bindSocket remoteSocket _remoteAddr - listen remoteSocket 1 - let handleRemote _socket = do - r@(_newSocket, _newSocketAddr) <- accept _socket - forkIO - catchAll - onException - (remoteRequestHandler config r) - do - pute "remote onException" - close _newSocket - - remoteLoop = - forever . - safeSocketHandler "Remote Connection" handleRemote - - pure (remoteSocket, remoteLoop) + setSocketOption _remoteSocket ReuseAddr 1 + bindSocket _remoteSocket _remoteAddr + listen _remoteSocket 1 - let debugRun :: IO () - debugRun = do - let _c = config - tryAddr (_c ^. local) (_c ^. localPort) - \_localAddr -> do - (localSocket, localLoop) <- localApp _localAddr + let handleRemote _socket = do + (_newSocket, _) <- accept _socket + forkIO - catchAll - + logSocket "Remote handler" (pure _newSocket) - + remoteRequestHandler config - tryAddr (_c ^. remote) (_c ^. remotePort) - \_remoteAddr -> do - (remoteSocket, remoteLoop) <- remoteApp _remoteAddr - catchAll - do - safeSocketHandler "Local Socket" (\_localSocket -> - safeSocketHandler "Remote Socket" (\_remoteSocket -> - waitBoth - (localLoop _localSocket) - (remoteLoop _remoteSocket) - ) remoteSocket) localSocket + forever - handleRemote _remoteSocket + let remoteRun :: IO () remoteRun = do let _c = config - tryAddr (_c ^. remote) (_c ^. remotePort) - \_remoteAddr -> do - (remoteSocket, remoteLoop) <- remoteApp _remoteAddr - catchAll - - safeSocketHandler "Remote Socket" remoteLoop remoteSocket + getSocket (_c ^. remote . _Text) (_c ^. remotePort) Stream + >>= catchAllLog "remote" . remoteApp localRun :: IO () localRun = do let _c = config - tryAddr (_c ^. local) (_c ^. localPort) - \_localAddr -> do - (localSocket, localLoop) <- localApp _localAddr - catchAll - - safeSocketHandler "Local Socket" localLoop localSocket + getSocket (_c ^. local . _Text) (_c ^. localPort) Stream + >>= catchAllLog "local" . localApp + debugRun :: IO () + debugRun = do + catchAllLog "both" - waitBoth localRun remoteRun + + 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 @@ -41,6 +41,11 @@ <> addressTypeBuilder (aClientRequest ^. addressType) <> foldMapOf each B.word8 (aClientRequest ^. portNumber) +shadowsocksRequestBuilder :: ClientRequest -> B.Builder +shadowsocksRequestBuilder aClientRequest = + addressTypeBuilder (aClientRequest ^. addressType) + <> foldMapOf each B.word8 (aClientRequest ^. portNumber) + addressTypeParser :: Parser AddressType addressTypeParser = choice [ @@ -59,6 +64,10 @@ count 16 anyWord8 ] +portParser :: Parser (Word8, Word8) +portParser = (,) <$> anyWord8 <*> anyWord8 + + requestParser :: Parser ClientRequest requestParser = do __connectionType <- choice @@ -74,5 +83,15 @@ pure - ClientRequest __connectionType + __addressType + __portNumber + +shadowsocksRequestParser :: Parser ClientRequest +shadowsocksRequestParser = do + __addressType <- addressTypeParser + __portNumber <- (,) <$> anyWord8 <*> anyWord8 + pure - + ClientRequest + TCP_IP_stream_connection __addressType __portNumber diff --git a/src/Network/MoeSocks/Config.hs b/src/Network/MoeSocks/Config.hs --- a/src/Network/MoeSocks/Config.hs +++ b/src/Network/MoeSocks/Config.hs @@ -1,16 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} module Network.MoeSocks.Config where -import "cipher-aes" Crypto.Cipher.AES -import Control.Lens -import Data.ByteString (ByteString) import Network.MoeSocks.Constant -import Network.MoeSocks.Helper import Network.MoeSocks.Type -import qualified Data.Text.Strict.Lens as TS defaultMoeConfig :: MoeConfig defaultMoeConfig = MoeConfig @@ -20,18 +13,8 @@ , _local = "127.0.0.1" , _localPort = 1090 , _password = "moesocks" - {-, _method = "none"-} + , _method = _DefaultMethod } - - -aesKey :: MoeConfig -> AES -aesKey _config = - let __password = - _config ^. password & review TS.utf8 :: ByteString - - _key = clamp _KeySize __password - in - initAES _key defaultMoeOptions :: MoeOptions diff --git a/src/Network/MoeSocks/Constant.hs b/src/Network/MoeSocks/Constant.hs --- a/src/Network/MoeSocks/Constant.hs +++ b/src/Network/MoeSocks/Constant.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + module Network.MoeSocks.Constant where import Data.Word -import GHC.Int (Int64) +import Data.Text (Text) _No_authentication :: Word8 _No_authentication = 0 @@ -12,16 +14,9 @@ _ReservedByte :: Word8 _ReservedByte = 0 -_KeySize :: Int -_KeySize = 32 - -_BlockSize :: Int -_BlockSize = 16 - -_PacketSize :: Int64 -_PacketSize = 256 - _SpaceCode :: Word8 _SpaceCode = 32 +_DefaultMethod :: Text +_DefaultMethod = "aes-256-cfb" 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,25 +5,23 @@ import Control.Concurrent import Control.Exception import Control.Lens -import Control.Monad.IO.Class +import Data.Aeson (Value()) import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString) import Data.Monoid import Data.Text (Text) import Data.Text.Lens +import Network.MoeSocks.Internal.ShadowSocks.Encrypt import Network.Socket import Prelude hiding (take, (-)) import System.IO -import System.IO.Streams (InputStream) -import System.IO.Streams.Attoparsec -import System.IO.Streams.List import System.IO.Unsafe import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Extra as BE import qualified Data.ByteString.Lazy as LB -import qualified Prelude as P +import qualified Data.Text.Strict.Lens as TS import qualified System.IO.Streams as Stream -- BEGIN backports @@ -37,6 +35,10 @@ _Debug :: Bool _Debug = True +boolToMaybe :: Bool -> Maybe () +boolToMaybe True = Just () +boolToMaybe False = Nothing + syncLock :: MVar () syncLock = unsafePerformIO - newEmptyMVar @@ -59,13 +61,28 @@ fromWord8 :: forall t. Binary t => [Word8] -> t fromWord8 = decode . runPut . mapM_ put -safeSocketHandler :: String -> (Socket -> IO a) -> Socket -> IO a -safeSocketHandler aID f aSocket = - catch (f aSocket) - \e -> do +logSocketWithAddress :: String -> IO (Socket, SockAddr) -> + ((Socket, SockAddr) -> IO a) -> IO a +logSocketWithAddress aID _init f = + catch (bracket _init (close .fst) f) - \e -> do pute - "Exception in " <> aID <> ": " <> show (e :: SomeException) - sClose aSocket throw e +logSA:: String -> IO (Socket, SockAddr) -> + ((Socket, SockAddr) -> IO a) -> IO a +logSA = logSocketWithAddress + +logSocket :: String -> IO Socket -> (Socket -> IO a) -> IO a +logSocket aID _init f = + catch (bracket _init close f) - \e -> do + pute - "Exception in " <> aID <> ": " <> show (e :: SomeException) + throw e + +catchAllLog :: String -> IO a -> IO () +catchAllLog aID io = catch (() <$ io) - \e -> + pute - "CatcheAll in " <> aID <> ": " + <> show (e :: SomeException) + catchAll :: IO a -> IO () catchAll io = catch (() <$ io) - \e -> pute - "CatcheAll: " <> show (e :: SomeException) @@ -77,18 +94,33 @@ waitBoth :: IO a -> IO b -> IO () waitBoth x y = do - (xThreadID, xLock) <- do - _lock <- newEmptyMVar - _threadID <- - forkFinally x - const - putMVar _lock () + let _init = do + (xThreadID, xLock) <- do + _lock <- newEmptyMVar + _threadID <- + forkFinally x - + const - putMVar _lock () - return (_threadID, _lock) + return (_threadID, _lock) - yThreadID <- - forkFinally y - const - killThread xThreadID + yThreadID <- + forkFinally y - const - killThread xThreadID + + return (xThreadID, xLock, yThreadID) + + let handleError (xThreadID, _, yThreadID) = do + killThread yThreadID + killThread xThreadID + + let action (_, xLock, yThreadID) = do + takeMVar xLock + killThread yThreadID + + bracket + _init + handleError + action - takeMVar xLock - killThread yThreadID pushStream :: (Stream.OutputStream ByteString) -> B.Builder -> IO () pushStream s b = do @@ -96,110 +128,48 @@ Stream.write (Just b) _builderStream Stream.write (Just BE.flush) _builderStream -tryAddr :: Text -> Int -> (SockAddr -> IO a) -> IO () -tryAddr aHostName aPort = tryAddr' (Just aHostName) (Just aPort) - (Just - defaultHints { addrSocketType = Stream }) -tryAddr' :: Maybe Text -> Maybe Int -> Maybe AddrInfo -> - (SockAddr -> IO a) -> IO () -tryAddr' aHostName aPort aHint f = do - addrInfo <- getAddrInfo - aHint - (fmap (view _Text) aHostName) - (fmap show aPort) - - {-puts - "tryAddr':" <> show addrInfo-} - let maybeAddr = addrInfo ^? traverse . to addrAddress - case maybeAddr of - Nothing -> pute - "Can not resolve: " <> show aHostName - Just _addr -> () <$ f _addr - -tryParse :: IO a -> IO () -tryParse io = flip catch (\e -> puts - show (e :: ParseException)) - () <$ io +getSocket :: (Integral i, Show i) => HostName -> i -> SocketType -> + IO (Socket, SockAddr) +getSocket aHost aPort aSocketType = do + maybeAddrInfo <- firstOf folded <$> + getAddrInfo (Just hints) (Just aHost) (Just $ show aPort) -withSocket :: Socket -> (Socket -> IO ()) -> IO () -withSocket aSocket f = do - f aSocket - sClose aSocket + case maybeAddrInfo of + Nothing -> error - "Error in getSocket for: " <> aHost <> ":" <> + show aPort + Just addrInfo -> do + let family = addrFamily addrInfo + let socketType = addrSocketType addrInfo + let protocol = addrProtocol addrInfo + let address = addrAddress addrInfo + _socket <- socket family socketType protocol -sockAddr_To_AddrFamily :: SockAddr -> Family -sockAddr_To_AddrFamily = f where - f (SockAddrInet {}) = AF_INET - f (SockAddrInet6 {}) = AF_INET6 - f (SockAddrUnix {}) = AF_UNIX - f _ = AF_INET + pure (_socket, address) + + where + hints = defaultHints { + addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV] + , addrSocketType = aSocketType + } -sockAddr_To_Port :: SockAddr -> String -sockAddr_To_Port = f where - f (SockAddrInet p _) = show p - f (SockAddrInet6 p _ _ _) = show p - f (SockAddrUnix {}) = "" - f _ = "" +builder_To_ByteString :: B.Builder -> ByteString +builder_To_ByteString = LB.toStrict . B.toLazyByteString -sockAddr_To_Host :: SockAddr -> String -sockAddr_To_Host = f where - f s@(SockAddrInet _ _) = P.takeWhile (/= ':') - show s - f s@(SockAddrInet6 _ _ _ _) = reverse - - P.dropWhile (== ':') - - P.dropWhile (/= ':') - - reverse - show s - f (SockAddrUnix s) = s - f _ = "" +type Cipher = ByteString -> IO ByteString -initSocketForType :: SockAddr -> SocketType -> IO Socket -initSocketForType aSockAddr aSocketType = - socket (sockAddr_To_AddrFamily aSockAddr) aSocketType defaultProtocol +getCipher :: Text -> Text -> IO (Cipher, Cipher) +getCipher method password = + getEncDec (method ^. _Text) (review TS.utf8 password) -initSocket :: SockAddr -> IO Socket -initSocket = flip initSocketForType Stream - -clamp :: (Integral i) => i -> ByteString -> ByteString -clamp i x = S.take (fromIntegral i) - x <> S.replicate (fromIntegral i) 0 - --- first bit is length -splitTokens :: Int -> ByteString -> [ByteString] -splitTokens l x - | l <= 1 = [x] - | x == mempty = [] - | otherwise = - let - byteLength = l + (-1) - (y, z) = S.splitAt byteLength x - length_y_byte = fromIntegral - S.length y - in - clamp l (S.cons length_y_byte y) : splitTokens l z - -tokenizeStream :: (Integral n) => n -> (ByteString -> ByteString) -> - InputStream ByteString -> IO (InputStream ByteString) -tokenizeStream n f input = - Stream.map (splitTokens - fromIntegral n) input - >>= concatLists >>= Stream.map f - -decodeToken :: ByteString -> ByteString -decodeToken x - | x == mempty = mempty - | otherwise = S.take (fromIntegral - S.head x) - S.tail x - -chunkStream :: (Integral n) => n -> InputStream ByteString -> - IO (InputStream ByteString) -chunkStream n input = Stream.fromGenerator - go - where - l = fromIntegral n - go = liftIO (Stream.read input) >>= maybe (return $! ()) chunk - chunk x - | S.length x >= l = Stream.yield (S.take l x) >> chunk (S.drop l x) - | otherwise = - liftIO (Stream.read input) >>= - maybe (Stream.yield x) (chunk . (x <>)) - -detokenizeStream :: (Integral n) => n -> (ByteString -> ByteString) -> - InputStream ByteString -> - IO (InputStream ByteString) -detokenizeStream n f input = Stream.map (decodeToken . f) =<< - chunkStream n input +portNumber16 :: (Word8, Word8) -> Word16 +portNumber16 pair = fromWord8 - toListOf both pair -builder_To_ByteString :: B.Builder -> ByteString -builder_To_ByteString = LB.toStrict . B.toLazyByteString +duplicateKey :: (Text, Text) -> [(Text, Value)] -> [(Text, Value)] +duplicateKey (_from, _to) l = + case lookup _from l of + Nothing -> l + Just v -> (_to,v) : l diff --git a/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs b/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs new file mode 100644 --- /dev/null +++ b/src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs @@ -0,0 +1,165 @@ +{- Original file from the shadowsocks package hosted on Hackage: + - https://hackage.haskell.org/package/shadowsocks + - Copyright: rnons + - Licence: MIT + -} + + +{- +The MIT License (MIT) + +Copyright (c) 2014 rnons + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +-} + + + +{-# LANGUAGE OverloadedStrings #-} +module Network.MoeSocks.Internal.ShadowSocks.Encrypt + ( getEncDec + , iv_len + ) where + +import Control.Concurrent.MVar ( newEmptyMVar, isEmptyMVar + , putMVar, readMVar) +import Crypto.Hash.MD5 (hash) +import Data.Binary.Get (runGet, getWord64le) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HM +import Data.IntMap.Strict (fromList, (!)) +import Data.List (sortBy) +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) +import Data.Word (Word8, Word64) +import OpenSSL (withOpenSSL) +import OpenSSL.EVP.Cipher (getCipherByName, CryptoMode(..)) +import OpenSSL.EVP.Internal (cipherInitBS, cipherUpdateBS) +import OpenSSL.Random (randBytes) + + +method_supported :: HM.HashMap String (Int, Int) +method_supported = HM.fromList + [ ("aes-128-cfb", (16, 16)) + , ("aes-192-cfb", (24, 16)) + , ("aes-256-cfb", (32, 16)) + , ("bf-cfb", (16, 8)) + , ("camellia-128-cfb", (16, 16)) + , ("camellia-192-cfb", (24, 16)) + , ("camellia-256-cfb", (32, 16)) + , ("cast5-cfb", (16, 8)) + , ("des-cfb", (8, 8)) + , ("idea-cfb", (16, 8)) + , ("rc2-cfb", (16, 8)) + , ("rc4", (16, 0)) + , ("seed-cfb", (16, 16)) + ] + +iv_len :: String -> Int +iv_len method = m1 + where + (_, m1) = method_supported HM.! method + +getTable :: ByteString -> [Word8] +getTable key = do + let s = L.fromStrict $ hash key + a = runGet getWord64le s + table = [0..255] + + map fromIntegral $ sortTable 1 a table + +sortTable :: Word64 -> Word64 -> [Word64] -> [Word64] +sortTable 1024 _ table = table +sortTable i a table = sortTable (i+1) a $ sortBy cmp table + where + cmp x y = compare (a `mod` (x + i)) (a `mod` (y + i)) + +evpBytesToKey :: ByteString -> Int -> Int -> (ByteString, ByteString) +evpBytesToKey password keyLen ivLen = + let ms' = S.concat $ ms 0 [] + key = S.take keyLen ms' + iv = S.take ivLen $ S.drop keyLen ms' + in (key, iv) + where + ms :: Int -> [ByteString] -> [ByteString] + ms 0 _ = ms 1 [hash password] + ms i m + | S.length (S.concat m) < keyLen + ivLen = + ms (i+1) (m ++ [hash (last m <> password)]) + | otherwise = m + +getSSLEncDec :: String -> ByteString + -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString) +getSSLEncDec method password = do + let (m0, m1) = fromJust $ HM.lookup method method_supported + random_iv <- withOpenSSL $ randBytes 32 + let cipher_iv = S.take m1 random_iv + let (key, _) = evpBytesToKey password m0 m1 + cipherCtx <- newEmptyMVar + decipherCtx <- newEmptyMVar + + cipherMethod <- fmap fromJust $ withOpenSSL $ getCipherByName method + 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 withOpenSSL $ cipherUpdateBS ctx buf + 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 withOpenSSL $ cipherUpdateBS dctx (S.drop m1 buf) + else do + dctx <- readMVar decipherCtx + withOpenSSL $ cipherUpdateBS dctx buf + + return (encrypt, decrypt) + +getTableEncDec :: ByteString + -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString) +getTableEncDec key = return (encrypt, decrypt) + where + table = getTable key + encryptTable = fromList $ zip [0..255] table + decryptTable = fromList $ zip (map fromIntegral table) [0..255] + encrypt :: ByteString -> IO ByteString + encrypt buf = return $ + S.pack $ map (\b -> encryptTable ! fromIntegral b) $ S.unpack buf + decrypt :: ByteString -> IO ByteString + decrypt buf = return $ + S.pack $ map (\b -> decryptTable ! fromIntegral b) $ S.unpack buf + +getEncDec :: String -> ByteString + -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString) +getEncDec "table" key = getTableEncDec key +getEncDec method key = getSSLEncDec method key diff --git a/src/Network/MoeSocks/OptionParser.hs b/src/Network/MoeSocks/OptionParser.hs --- a/src/Network/MoeSocks/OptionParser.hs +++ b/src/Network/MoeSocks/OptionParser.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module Network.MoeSocks.OptionParser where 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 @@ -1,6 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Network.MoeSocks.Type where @@ -50,7 +48,7 @@ , _local :: Text , _localPort :: Int , _password :: Text - {-, _method :: Text-} + , _method :: Text } deriving (Show, Eq, Generic) @@ -70,3 +68,6 @@ deriving (Show, Eq) makeLenses ''MoeOptions + + +type Cipher = ByteString -> IO ByteString