diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 1.20180408 + +* Update to conduit-1.3 + ## 1.20151028 * Turn off `-threaded` option for Windows 64bit diff --git a/Shadowsocks/Encrypt.hs b/Shadowsocks/Encrypt.hs deleted file mode 100644 --- a/Shadowsocks/Encrypt.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module 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.Char8 as C -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 -> String - -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString) -getEncDec "table" key = getTableEncDec $ C.pack key -getEncDec method key = getSSLEncDec method $ C.pack key diff --git a/Shadowsocks/Util.hs b/Shadowsocks/Util.hs deleted file mode 100644 --- a/Shadowsocks/Util.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Shadowsocks.Util - ( Config (..) - , cryptConduit - , parseConfigOptions - , unpackRequest - , packRequest - , packSockAddr - ) where - -import Conduit (Conduit, awaitForever, yield, liftIO) -import Control.Monad (liftM) -import Data.Aeson (decode', FromJSON) -import Data.Binary (decode) -import Data.Binary.Get (runGet, getWord16be, getWord32le) -import Data.Binary.Put (runPut, putWord16be, putWord32le) -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Char8 as C -import Data.Char (chr, ord) -import Data.IP ( fromHostAddress, fromHostAddress6 - , toHostAddress, toHostAddress6) -import Data.Maybe (fromMaybe) -import GHC.Generics (Generic) -import Network.Socket (HostAddress, HostAddress6, SockAddr(..)) -import Options.Applicative - -data Config = Config - { server :: String - , server_port :: Int - , local_port :: Int - , password :: String - , timeout :: Int - , method :: String - } deriving (Show, Generic) - -instance FromJSON Config - -data Options = Options - { _server :: Maybe String - , _server_port :: Maybe Int - , _local_port :: Maybe Int - , _password :: Maybe String - , _method :: Maybe String - , _config :: Maybe String - } deriving (Show, Generic) - -nullConfig :: Config -nullConfig = Config "" 0 0 "" 0 "" - -readConfig :: FilePath -> IO (Maybe Config) -readConfig fp = liftM decode' $ L.readFile fp - -configOptions :: Parser Options -configOptions = Options - <$> optional (strOption (long "server" <> short 's' <> metavar "ADDR" - <> help "server address")) - <*> optional (option auto (long "server-port" <> short 'p' <> metavar "PORT" - <> help "server port")) - <*> optional (option auto (long "local-port" <> short 'l' <> metavar "PORT" - <> help "local port")) - <*> optional (strOption (long "password" <> short 'k' <> metavar "PASSWORD" - <> help "password")) - <*> optional (strOption (long "method" <> short 'm' <> metavar "METHOD" - <> help "encryption method, for example, aes-256-cfb")) - <*> optional (strOption (long "config" <> short 'c' <> metavar "CONFIG" - <> help "path to config file")) - -parseConfigOptions :: IO Config -parseConfigOptions = do - o <- execParser $ info (helper <*> configOptions) - (fullDesc <> header "shadowsocks - a fast tunnel proxy") - let configFile = fromMaybe "config.json" (_config o) - mconfig <- readConfig configFile - let c = fromMaybe nullConfig mconfig - return $ c { server = fromMaybe (server c) (_server o) - , server_port = fromMaybe (server_port c) (_server_port o) - , local_port = fromMaybe (local_port c) (_local_port o) - , password = fromMaybe (password c) (_password o) - , method = fromMaybe (method c) (_method o) - } - -cryptConduit :: (ByteString -> IO ByteString) - -> Conduit ByteString IO ByteString -cryptConduit crypt = awaitForever $ \input -> do - output <- liftIO $ crypt input - yield output - -unpackRequest :: ByteString -> (Int, ByteString, Int, ByteString) -unpackRequest request = (addrType, destAddr, destPort, payload) - where - addrType = fromIntegral $ S.head request - request' = S.drop 1 request - (destAddr, port, payload) = case addrType of - 1 -> -- IPv4 - let (ip, rest) = S.splitAt 4 request' - addr = C.pack $ show $ fromHostAddress $ runGet getWord32le - $ L.fromStrict ip - in (addr, S.take 2 rest, S.drop 2 rest) - 3 -> -- domain name - let addrLen = ord $ C.head request' - (domain, rest) = S.splitAt (addrLen + 1) request' - in (S.tail domain, S.take 2 rest, S.drop 2 rest) - 4 -> -- IPv6 - let (ip, rest) = S.splitAt 16 request' - addr = C.pack $ show $ fromHostAddress6 $ decode - $ L.fromStrict ip - in (addr, S.take 2 rest, S.drop 2 rest) - _ -> error $ "Unknown address type: " <> show addrType - destPort = fromIntegral $ runGet getWord16be $ L.fromStrict port - -packPort :: Int -> ByteString -packPort = L.toStrict . runPut . putWord16be . fromIntegral - -packInet :: HostAddress -> Int -> ByteString -packInet host port = - "\x01" <> L.toStrict (runPut $ putWord32le host) - <> packPort port - -packInet6 :: HostAddress6 -> Int -> ByteString -packInet6 (h1, h2, h3, h4) port = - "\x04" <> L.toStrict (runPut (putWord32le h1) - <> runPut (putWord32le h2) - <> runPut (putWord32le h3) - <> runPut (putWord32le h4)) - <> packPort port - -packDomain :: ByteString -> Int -> ByteString -packDomain host port = - "\x03" <> C.singleton (chr $ S.length host) <> host <> packPort port - -packRequest :: Int -> ByteString -> Int -> ByteString -packRequest addrType destAddr destPort = - case addrType of - 1 -> packInet (toHostAddress $ read $ C.unpack destAddr) destPort - 3 -> packDomain destAddr destPort - 4 -> packInet6 (toHostAddress6 $ read $ C.unpack destAddr) destPort - _ -> error $ "Unknown address type: " <> show addrType - -packSockAddr :: SockAddr -> ByteString -packSockAddr addr = - case addr of - SockAddrInet port host -> packInet host $ fromIntegral port - SockAddrInet6 port _ host _ -> packInet6 host $ fromIntegral port - _ -> error "unix socket is not supported" diff --git a/app/local.hs b/app/local.hs new file mode 100644 --- /dev/null +++ b/app/local.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Conduit (ConduitT, await, connect, leftover, + liftIO, yield, ($$+), ($$++), ($$+-), + (.|)) +import Control.Concurrent.Async (race_) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import Data.Conduit.Network (appSink, appSource, clientSettings, + runTCPClient, runTCPServer, + serverSettings) +import Data.Monoid ((<>)) +import GHC.IO.Handle (BufferMode (NoBuffering), + hSetBuffering) +import GHC.IO.Handle.FD (stdout) + +import Shadowsocks.Encrypt (getEncDec) +import Shadowsocks.Util + +initLocal :: ConduitT ByteString ByteString IO () +initLocal = do + await + yield "\x05\x00" + await >>= maybe (return ()) (\request -> do + let (addrType, destAddr, destPort, _) = + either (error . show . UnknownAddrType) + id + (unpackRequest $ S.drop 3 request) + packed = packRequest addrType destAddr destPort + yield "\x05\x00\x00\x01\x00\x00\x00\x00\x10\x10" + liftIO $ C.putStrLn $ "connecting " <> destAddr + <> ":" <> C.pack (show destPort) + leftover packed) + +initRemote :: (ByteString -> IO ByteString) + -> ConduitT ByteString ByteString IO () +initRemote encrypt = do + mAddrToSend <- await + case mAddrToSend of + Just addrToSend -> do + enc <- liftIO $ encrypt addrToSend + yield enc + Nothing -> return () + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + config <- parseConfigOptions + let localSettings = serverSettings (localPort config) "*" + remoteSettings = clientSettings (serverPort config) + (C.pack $ server config) + C.putStrLn $ "starting local at " <> C.pack (show $ localPort config) + runTCPServer localSettings $ \client -> do + (encrypt, decrypt) <- getEncDec (method config) (password config) + (clientSource, ()) <- appSource client $$+ initLocal .| appSink client + runTCPClient remoteSettings $ \appServer -> do + (clientSource', ()) <- + clientSource $$++ initRemote encrypt .| appSink appServer + race_ + (clientSource' $$+- cryptConduit encrypt .| appSink appServer) + (appSource appServer `Conduit.connect` + (cryptConduit decrypt .| appSink client)) diff --git a/app/server.hs b/app/server.hs new file mode 100644 --- /dev/null +++ b/app/server.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Conduit (ConduitT, Void, await, connect, + liftIO, ($$+), ($$+-), (.|)) +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) +import Control.Concurrent.Async (race_) +import Control.Exception (throwIO) +import Control.Monad (forever) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C +import Data.Conduit (catchC) +import Data.Conduit.Network (appSink, appSockAddr, appSource, + clientSettings, runTCPClient, + runTCPServer, serverSettings) +import Data.Monoid ((<>)) +import Data.Streaming.Network (bindPortUDP) +import GHC.IO.Handle (BufferMode (NoBuffering), + hSetBuffering) +import GHC.IO.Handle.FD (stdout) +import Network.Socket hiding (recvFrom) +import Network.Socket.ByteString (recvFrom, sendAllTo) + +import Shadowsocks.Encrypt (getEncDec) +import Shadowsocks.Util + +initRemote :: (ByteString -> IO ByteString) + -> ConduitT ByteString Void IO (ByteString, Int) +initRemote decrypt = await >>= + maybe (liftIO $ throwIO NoRequestBody) (\encRequest -> do + request <- liftIO $ decrypt encRequest + case unpackRequest request of + Right (_, destAddr, destPort, _) -> return (destAddr, destPort) + Left addrType -> liftIO $ throwIO $ UnknownAddrType addrType + ) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + config <- parseConfigOptions + let localSettings = serverSettings (serverPort config) "*" + C.putStrLn $ "starting server at " <> C.pack (show $ serverPort config) + + udpSocket <- bindPortUDP (serverPort config) "*" + forkIO $ forever $ do + (encRequest, sourceAddr) <- recvFrom udpSocket 65535 + forkIO $ do + (encrypt, decrypt) <- getEncDec (method config) (password config) + request <- decrypt encRequest + let (_, destAddr, destPort, payload) = + either (error . show . UnknownAddrType) + id + (unpackRequest request) + C.putStrLn $ "udp " <> destAddr <> ":" <> C.pack (show destPort) + remoteAddr <- head <$> + getAddrInfo Nothing (Just $ C.unpack destAddr) + (Just $ show destPort) + + remote <- socket (addrFamily remoteAddr) Datagram defaultProtocol + sendAllTo remote payload (addrAddress remoteAddr) + (packet', sockAddr) <- recvFrom remote 65535 + let packed = packSockAddr sockAddr + packet <- encrypt $ packed <> packet' + sendAllTo udpSocket packet sourceAddr + close remote + + runTCPServer localSettings $ \client -> do + (encrypt, decrypt) <- getEncDec (method config) (password config) + (clientSource, (host, port)) <- + appSource client $$+ + initRemote decrypt `catchC` \e -> + error $ show (e :: SSException) <> " from " + <> showSockAddr (appSockAddr client) + let remoteSettings = clientSettings port host + C.putStrLn $ "connecting " <> host <> ":" <> C.pack (show port) + runTCPClient remoteSettings $ \appServer -> race_ + (clientSource $$+- cryptConduit decrypt .| appSink appServer) + (appSource appServer `Conduit.connect` + (cryptConduit encrypt .| appSink client)) diff --git a/local.hs b/local.hs deleted file mode 100644 --- a/local.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Conduit ( Conduit, await, leftover, yield, liftIO - , (=$), ($$), ($$+), ($$++), ($$+-)) -import Control.Concurrent.Async (race_) -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as C -import Data.Conduit.Network ( runTCPServer, runTCPClient - , serverSettings, clientSettings - , appSource, appSink) -import Data.Monoid ((<>)) -import GHC.IO.Handle (hSetBuffering, BufferMode(NoBuffering)) -import GHC.IO.Handle.FD (stdout) - -import Shadowsocks.Encrypt (getEncDec) -import Shadowsocks.Util - -initLocal :: Conduit ByteString IO ByteString -initLocal = do - await - yield "\x05\x00" - await >>= maybe (return ()) (\request -> do - let (addrType, destAddr, destPort, _) = unpackRequest (S.drop 3 request) - packed = packRequest addrType destAddr destPort - yield "\x05\x00\x00\x01\x00\x00\x00\x00\x10\x10" - liftIO $ C.putStrLn $ "connecting " <> destAddr - <> ":" <> C.pack (show destPort) - leftover packed) - -initRemote :: (ByteString -> IO ByteString) - -> Conduit ByteString IO ByteString -initRemote encrypt = do - mAddrToSend <- await - case mAddrToSend of - Just addrToSend -> do - enc <- liftIO $ encrypt addrToSend - yield enc - Nothing -> return () - -main :: IO () -main = do - hSetBuffering stdout NoBuffering - config <- parseConfigOptions - let localSettings = serverSettings (local_port config) "*" - remoteSettings = clientSettings (server_port config) - (C.pack $ server config) - C.putStrLn $ "starting local at " <> C.pack (show $ local_port config) - runTCPServer localSettings $ \client -> do - (encrypt, decrypt) <- getEncDec (method config) (password config) - (clientSource, ()) <- appSource client $$+ initLocal =$ appSink client - runTCPClient remoteSettings $ \appServer -> do - (clientSource', ()) <- - clientSource $$++ initRemote encrypt =$ appSink appServer - race_ - (clientSource' $$+- cryptConduit encrypt =$ appSink appServer) - (appSource appServer $$ cryptConduit decrypt =$ appSink client) diff --git a/server.hs b/server.hs deleted file mode 100644 --- a/server.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Conduit (Sink, await, liftIO, (=$), ($$), ($$+), ($$+-)) -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.Async (race_) -import Control.Monad (forever) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C -import Data.Conduit.Network ( runTCPServer, runTCPClient - , serverSettings, clientSettings - , appSource, appSink) -import Data.Monoid ((<>)) -import Data.Streaming.Network(bindPortUDP) -import GHC.IO.Handle (hSetBuffering, BufferMode(NoBuffering)) -import GHC.IO.Handle.FD (stdout) -import Network.Socket hiding (recvFrom) -import Network.Socket.ByteString (recvFrom, sendAllTo) - -import Shadowsocks.Encrypt (getEncDec) -import Shadowsocks.Util - -initRemote :: (ByteString -> IO ByteString) - -> Sink ByteString IO (ByteString, Int) -initRemote decrypt = await >>= - maybe (error "Invalid request") (\encRequest -> do - request <- liftIO $ decrypt encRequest - let (_, destAddr, destPort, _) = unpackRequest request - return (destAddr, destPort)) - -main :: IO () -main = do - hSetBuffering stdout NoBuffering - config <- parseConfigOptions - let localSettings = serverSettings (server_port config) "*" - C.putStrLn $ "starting server at " <> C.pack (show $ server_port config) - - udpSocket <- bindPortUDP (server_port config) "*" - forkIO $ forever $ do - (encRequest, sourceAddr) <- recvFrom udpSocket 65535 - forkIO $ do - (encrypt, decrypt) <- getEncDec (method config) (password config) - request <- decrypt encRequest - let (_, destAddr, destPort, payload) = unpackRequest request - C.putStrLn $ "udp " <> destAddr <> ":" <> C.pack (show destPort) - remoteAddr <- head <$> - getAddrInfo Nothing (Just $ C.unpack destAddr) - (Just $ show destPort) - - remote <- socket (addrFamily remoteAddr) Datagram defaultProtocol - sendAllTo remote payload (addrAddress remoteAddr) - (packet', sockAddr) <- recvFrom remote 65535 - let packed = packSockAddr sockAddr - packet <- encrypt $ packed <> packet' - sendAllTo udpSocket packet sourceAddr - close remote - - runTCPServer localSettings $ \client -> do - (encrypt, decrypt) <- getEncDec (method config) (password config) - (clientSource, (host, port)) <- - appSource client $$+ initRemote decrypt - let remoteSettings = clientSettings port host - C.putStrLn $ "connecting " <> host <> ":" <> C.pack (show port) - runTCPClient remoteSettings $ \appServer -> race_ - (clientSource $$+- cryptConduit decrypt =$ appSink appServer) - (appSource appServer $$ cryptConduit encrypt =$ appSink client) diff --git a/shadowsocks.cabal b/shadowsocks.cabal --- a/shadowsocks.cabal +++ b/shadowsocks.cabal @@ -1,5 +1,5 @@ name: shadowsocks -version: 1.20151028 +version: 1.20180408 synopsis: A fast SOCKS5 proxy that help you get through firewalls description: Shadowsocks implemented in Haskell. Original python version: @@ -11,8 +11,8 @@ maintainer: remotenonsense@gmail.com category: Web build-type: Simple -cabal-version: >= 1.10 -tested-with: GHC == 7.10.2 +cabal-version: 1.18 +tested-with: GHC == 8.2.2 data-files: config.json extra-doc-files: CHANGELOG.md @@ -20,24 +20,18 @@ type: git location: git://github.com/rnons/shadowsocks-haskell.git -executable sslocal - main-is: local.hs - if os(windows) && arch(x86_64) - ghc-options: -Wall -fno-warn-unused-do-bind -O2 - else - ghc-options: -Wall -fno-warn-unused-do-bind -O2 -threaded - other-modules: Shadowsocks.Encrypt, +library + hs-source-dirs: src + exposed-modules: Shadowsocks.Encrypt, Shadowsocks.Util - other-extensions: OverloadedStrings, DeriveGeneric build-depends: base == 4.*, aeson >= 0.7, - async >= 2.0, binary >= 0.7, bytestring >= 0.9, - conduit-combinators >= 1.0, - conduit-extra >= 1.1, + conduit >= 1.3, containers >= 0.5, cryptohash >= 0.11, + directory, HsOpenSSL >= 0.11, iproute >= 1.4, network >= 2.6, @@ -45,30 +39,38 @@ unordered-containers >= 0.2 default-language: Haskell2010 +executable sslocal + hs-source-dirs: app + main-is: local.hs + if os(windows) && arch(x86_64) + ghc-options: -Wall -fno-warn-unused-do-bind + else + ghc-options: -Wall -fno-warn-unused-do-bind -threaded + other-extensions: OverloadedStrings, DeriveGeneric + build-depends: base == 4.*, + shadowsocks, + async >= 2.0, + bytestring >= 0.9, + conduit >= 1.3, + conduit-extra >= 1.3 + default-language: Haskell2010 + executable ssserver + hs-source-dirs: app main-is: server.hs if os(windows) && arch(x86_64) - ghc-options: -Wall -fno-warn-unused-do-bind -O2 + ghc-options: -Wall -fno-warn-unused-do-bind else - ghc-options: -Wall -fno-warn-unused-do-bind -O2 -threaded - other-modules: Shadowsocks.Encrypt, - Shadowsocks.Util + ghc-options: -Wall -fno-warn-unused-do-bind -threaded other-extensions: OverloadedStrings, DeriveGeneric build-depends: base == 4.*, - aeson >= 0.7, + shadowsocks, async >= 2.0, - binary >= 0.7, bytestring >= 0.9, - conduit-combinators >= 1.0, - conduit-extra >= 1.1, - containers >= 0.5, - cryptohash >= 0.11, - HsOpenSSL >= 0.11, - iproute >= 1.4, + conduit >= 1.3, + conduit-extra >= 1.3, network >= 2.6, - optparse-applicative >= 0.11, - streaming-commons >= 0.1.11, - unordered-containers >= 0.2 + streaming-commons >= 0.1.11 default-language: Haskell2010 test-suite test diff --git a/src/Shadowsocks/Encrypt.hs b/src/Shadowsocks/Encrypt.hs new file mode 100644 --- /dev/null +++ b/src/Shadowsocks/Encrypt.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +module Shadowsocks.Encrypt + ( getEncDec + ) 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.Char8 as C +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) + + +methodSupported :: HM.HashMap String (Int, Int) +methodSupported = 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)) + ] + +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 methodSupported + 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 -> String + -> IO (ByteString -> IO ByteString, ByteString -> IO ByteString) +getEncDec "table" key = getTableEncDec $ C.pack key +getEncDec method key = getSSLEncDec method $ C.pack key diff --git a/src/Shadowsocks/Util.hs b/src/Shadowsocks/Util.hs new file mode 100644 --- /dev/null +++ b/src/Shadowsocks/Util.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Shadowsocks.Util + ( Config (..) + , cryptConduit + , parseConfigOptions + , unpackRequest + , packRequest + , packSockAddr + , showSockAddr + , SSException(..) + ) where + +import Conduit (ConduitT, awaitForever, liftIO, yield) +import Control.Exception (Exception, IOException, catch) +import Data.Aeson (FromJSON (..), Value (..), decode', + (.:)) +import Data.Binary (decode) +import Data.Binary.Get (getWord16be, getWord32le, runGet) +import Data.Binary.Put (putWord16be, putWord32le, runPut) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Data.Char (chr, ord) +import Data.IP (fromHostAddress, fromHostAddress6, + toHostAddress, toHostAddress6) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.Socket (HostAddress, HostAddress6, + SockAddr (..)) +import Options.Applicative +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +data Config = Config + { server :: String + , serverPort :: Int + , localPort :: Int + , password :: String + , timeout :: Int + , method :: String + } deriving (Show, Generic) + +instance FromJSON Config where + parseJSON (Object v) = Config <$> v .: "server" + <*> v .: "server_port" + <*> v .: "local_port" + <*> v .: "password" + <*> v .: "timeout" + <*> v .: "method" + +data Options = Options + { _server :: Maybe String + , _serverPort :: Maybe Int + , _localPort :: Maybe Int + , _password :: Maybe String + , _method :: Maybe String + , _config :: Maybe String + } deriving (Show, Generic) + +type AddrType = Int + +data SSException = UnknownAddrType AddrType + | NoRequestBody + deriving (Show, Typeable) + +instance Exception SSException + + +nullConfig :: Config +nullConfig = Config "" 0 0 "" 0 "" + +readConfig :: FilePath -> IO (Maybe Config) +readConfig fp = decode' <$> L.readFile fp + +configOptions :: Parser Options +configOptions = Options + <$> optional (strOption (long "server" <> short 's' <> metavar "ADDR" + <> help "server address")) + <*> optional (option auto (long "server-port" <> short 'p' <> metavar "PORT" + <> help "server port")) + <*> optional (option auto (long "local-port" <> short 'l' <> metavar "PORT" + <> help "local port")) + <*> optional (strOption (long "password" <> short 'k' <> metavar "PASSWORD" + <> help "password")) + <*> optional (strOption (long "method" <> short 'm' <> metavar "METHOD" + <> help "encryption method, for example, aes-256-cfb")) + <*> optional (strOption (long "config" <> short 'c' <> metavar "CONFIG" + <> help "path to config file")) + +parseConfigOptions :: IO Config +parseConfigOptions = do + o <- execParser $ info (helper <*> configOptions) + (fullDesc <> header "shadowsocks - a fast tunnel proxy") + let configFile = fromMaybe "config.json" (_config o) + mconfig <- readConfig configFile `catch` \(e :: IOException) -> + hPutStrLn stderr ("ERROR: Failed to load " <> show e) >> exitFailure + let c = fromMaybe nullConfig mconfig + return $ c { server = fromMaybe (server c) (_server o) + , serverPort = fromMaybe (serverPort c) (_serverPort o) + , localPort = fromMaybe (localPort c) (_localPort o) + , password = fromMaybe (password c) (_password o) + , method = fromMaybe (method c) (_method o) + } + +cryptConduit :: (ByteString -> IO ByteString) + -> ConduitT ByteString ByteString IO () +cryptConduit crypt = awaitForever $ \input -> do + output <- liftIO $ crypt input + yield output + +unpackRequest :: ByteString -> Either AddrType (AddrType, ByteString, Int, ByteString) +unpackRequest request = case addrType of + 1 -> -- IPv4 + let (ip, rest) = S.splitAt 4 request' + addr = C.pack $ show $ fromHostAddress $ runGet getWord32le + $ L.fromStrict ip + in Right (addrType, addr, unpackPort rest, S.drop 2 rest) + 3 -> -- domain name + let addrLen = ord $ C.head request' + (domain, rest) = S.splitAt (addrLen + 1) request' + in Right (addrType, S.tail domain, unpackPort rest, S.drop 2 rest) + 4 -> -- IPv6 + let (ip, rest) = S.splitAt 16 request' + addr = C.pack $ show $ fromHostAddress6 $ decode + $ L.fromStrict ip + in Right (addrType, addr, unpackPort rest, S.drop 2 rest) + _ -> Left addrType + where + addrType = fromIntegral $ S.head request + request' = S.drop 1 request + unpackPort = fromIntegral . runGet getWord16be . L.fromStrict . S.take 2 + +packPort :: Int -> ByteString +packPort = L.toStrict . runPut . putWord16be . fromIntegral + +packInet :: HostAddress -> Int -> ByteString +packInet host port = + "\x01" <> L.toStrict (runPut $ putWord32le host) + <> packPort port + +packInet6 :: HostAddress6 -> Int -> ByteString +packInet6 (h1, h2, h3, h4) port = + "\x04" <> L.toStrict (runPut (putWord32le h1) + <> runPut (putWord32le h2) + <> runPut (putWord32le h3) + <> runPut (putWord32le h4)) + <> packPort port + +packDomain :: ByteString -> Int -> ByteString +packDomain host port = + "\x03" <> C.singleton (chr $ S.length host) <> host <> packPort port + +packRequest :: Int -> ByteString -> Int -> ByteString +packRequest addrType destAddr destPort = + case addrType of + 1 -> packInet (toHostAddress $ read $ C.unpack destAddr) destPort + 3 -> packDomain destAddr destPort + 4 -> packInet6 (toHostAddress6 $ read $ C.unpack destAddr) destPort + _ -> error $ "Unknown address type: " <> show addrType + +packSockAddr :: SockAddr -> ByteString +packSockAddr addr = + case addr of + SockAddrInet port host -> packInet host $ fromIntegral port + SockAddrInet6 port _ host _ -> packInet6 host $ fromIntegral port + _ -> error "unix socket is not supported" + +showSockAddr :: SockAddr -> String +showSockAddr addr = + case addr of + SockAddrInet port host -> + show (fromHostAddress host) <> ":" <> show port + SockAddrInet6 port _ host _ -> + show (fromHostAddress6 host) <> ":" <> show port + _ -> error "unix socket is not supported"