moesocks 0.1.0.0 → 0.1.0.1
raw patch · 11 files changed
+471/−413 lines, 11 filesdep +HsOpenSSLdep +containersdep +cryptohashdep −cipher-aes
Dependencies added: HsOpenSSL, containers, cryptohash
Dependencies removed: cipher-aes
Files
- config.json +6/−5
- moesocks.cabal +9/−6
- src/Main.hs +0/−4
- src/Network/MoeSocks/App.hs +178/−251
- src/Network/MoeSocks/BuilderAndParser.hs +19/−0
- src/Network/MoeSocks/Config.hs +1/−18
- src/Network/MoeSocks/Constant.hs +5/−10
- src/Network/MoeSocks/Helper.hs +84/−114
- src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs +165/−0
- src/Network/MoeSocks/OptionParser.hs +0/−2
- src/Network/MoeSocks/Type.hs +4/−3
config.json view
@@ -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" }
moesocks.cabal view
@@ -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
src/Main.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}- module Main where import Network.MoeSocks.App
src/Network/MoeSocks/App.hs view
@@ -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 -
src/Network/MoeSocks/BuilderAndParser.hs view
@@ -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
src/Network/MoeSocks/Config.hs view
@@ -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
src/Network/MoeSocks/Constant.hs view
@@ -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"
src/Network/MoeSocks/Helper.hs view
@@ -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
+ src/Network/MoeSocks/Internal/ShadowSocks/Encrypt.hs view
@@ -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
src/Network/MoeSocks/OptionParser.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-} module Network.MoeSocks.OptionParser where
src/Network/MoeSocks/Type.hs view
@@ -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