shadowsocks 1.20151028 → 1.20180408
raw patch · 10 files changed
+487/−433 lines, 10 filesdep +conduitdep +directorydep +shadowsocksdep −conduit-combinatorsdep ~conduit-extra
Dependencies added: conduit, directory, shadowsocks
Dependencies removed: conduit-combinators
Dependency ranges changed: conduit-extra
Files
- CHANGELOG.md +4/−0
- Shadowsocks/Encrypt.hs +0/−133
- Shadowsocks/Util.hs +0/−148
- app/local.hs +63/−0
- app/server.hs +79/−0
- local.hs +0/−57
- server.hs +0/−66
- shadowsocks.cabal +31/−29
- src/Shadowsocks/Encrypt.hs +127/−0
- src/Shadowsocks/Util.hs +183/−0
CHANGELOG.md view
@@ -1,3 +1,7 @@+## 1.20180408++* Update to conduit-1.3+ ## 1.20151028 * Turn off `-threaded` option for Windows 64bit
− Shadowsocks/Encrypt.hs
@@ -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
− Shadowsocks/Util.hs
@@ -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"
+ app/local.hs view
@@ -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))
+ app/server.hs view
@@ -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))
− local.hs
@@ -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)
− server.hs
@@ -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)
shadowsocks.cabal view
@@ -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: <https://github.com/clowwindy/shadowsocks>@@ -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
+ src/Shadowsocks/Encrypt.hs view
@@ -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
+ src/Shadowsocks/Util.hs view
@@ -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"