From 38b465980facab3ef14568c06b7b3227607dc668 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Er=C3=A8be?= Date: Sat, 21 May 2016 15:41:56 +0200 Subject: [PATCH] Add tls server --- app/Main.hs | 2 +- src/Lib.hs | 52 +++++++++++++++++++++++++++++++---------------- stack.yaml | 55 +++++++++++++++++++++++++++++++++++++++----------- wstunnel.cabal | 7 ++++--- 4 files changed, 83 insertions(+), 33 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 459f2b5..d1f5764 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ main = do if serverMode cfg then putStrLn ("Starting server with opts " ++ show serverInfo ) - >> runServer (host serverInfo, fromIntegral $ port serverInfo) (parseRestrictTo $ restrictTo cfg) + >> runServer (useTls serverInfo) (host serverInfo, fromIntegral $ port serverInfo) (parseRestrictTo $ restrictTo cfg) else if not $ null (localToRemote cfg) then let (TunnelInfo lHost lPort rHost rPort) = parseTunnelInfo (localToRemote cfg) in runClient (useTls serverInfo) (if udpMode cfg then UDP else TCP) (lHost, (fromIntegral lPort)) diff --git a/src/Lib.hs b/src/Lib.hs index 47d2e6f..df1b96a 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -19,7 +19,9 @@ import System.Timeout (timeout) import qualified Data.ByteString.Char8 as BC +import qualified Data.Conduit.Network.TLS as N import qualified Data.Streaming.Network as N + import Network.Socket (HostName, PortNumber) import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo) @@ -133,13 +135,28 @@ runTunnelingClient proto (wsHost, wsPort) (remoteHost, remotePort) app = do putStrLn $ "CLOSE connection to " <> tshow remoteHost <> ":" <> tshow remotePort +runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () +runTlsTunnelingServer (bindTo, portNumber) isAllowed = do + putStrLn $ "WAIT for TLS connection on " <> tshow bindTo <> ":" <> tshow portNumber + N.runTCPServerTLS (N.tlsConfig (fromString bindTo) (fromIntegral portNumber) "/tmp/ssl/server.crt" "/tmp/ssl/server.key") $ \sClient -> + runApp sClient WS.defaultConnectionOptions (runServerEventLoop isAllowed) + + putStrLn "CLOSE server" + + where + runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO () + runApp appData opts app= do + stream <- WS.makeStream (Just <$> N.appRead appData) (N.appWrite appData . toStrict . fromJust) + bracket (WS.makePendingConnectionFromStream stream opts) + (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ())) + app runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () runTunnelingServer (host, port) isAllowed = do putStrLn $ "WAIT for connection on " <> tshow host <> ":" <> tshow port void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) $ \sClient -> - runApp (fromJust $ N.appRawSocket sClient) WS.defaultConnectionOptions runEventLoop + runApp (fromJust $ N.appRawSocket sClient) WS.defaultConnectionOptions (runServerEventLoop isAllowed) putStrLn "CLOSE server" @@ -148,20 +165,21 @@ runTunnelingServer (host, port) isAllowed = do runApp socket opts = bracket (WS.makePendingConnection socket opts) (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ())) - runEventLoop pendingConn = do - let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn - case path of - Nothing -> putStrLn "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information" - Just (!proto, !rhost, !rport) -> - if not $ isAllowed (rhost, rport) - then do - putStrLn "Rejecting tunneling" - WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling" - else do - conn <- WS.acceptRequest pendingConn - case proto of - UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn) - TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn) +runServerEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO () +runServerEventLoop isAllowed pendingConn = do + let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn + case path of + Nothing -> putStrLn "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information" + Just (!proto, !rhost, !rport) -> + if not $ isAllowed (rhost, rport) + then do + putStrLn "Rejecting tunneling" + WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling" + else do + conn <- WS.acceptRequest pendingConn + case proto of + UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn) + TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn) @@ -190,8 +208,8 @@ runClient useTls proto local wsServer remote = do TCP -> runTCPServer local (\hOther -> out (`propagateRW` hOther)) -runServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () -runServer = runTunnelingServer +runServer :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () +runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer runTlsTunnelingClient :: Proto -> (HostName, PortNumber) -> (HostName, PortNumber) -> (WS.Connection -> IO ()) -> IO () diff --git a/stack.yaml b/stack.yaml index 749f79f..b236216 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,13 +1,44 @@ -# This file was automatically generated by stack init -# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ -# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-5.16 +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-5.17 -# Local packages, usually specified by relative directory name +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. packages: - '.' -# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) extra-deps: [] # Override default flag values for local packages and extra-deps @@ -18,18 +49,18 @@ extra-package-dbs: [] # Control whether we use the GHC we find on the path # system-ghc: true - +# # Require a specific version of stack, using version ranges # require-stack-version: -any # Default -# require-stack-version: >= 1.0.0 - +# require-stack-version: ">=1.1" +# # Override the architecture used by stack, especially useful on Windows # arch: i386 # arch: x86_64 - +# # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] - +# # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor +# compiler-check: newer-minor \ No newline at end of file diff --git a/wstunnel.cabal b/wstunnel.cabal index 0b15db5..f0d3840 100644 --- a/wstunnel.cabal +++ b/wstunnel.cabal @@ -16,15 +16,16 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Lib - build-depends: base >= 4.7 && < 5 + build-depends: base , classy-prelude , bytestring , async , unordered-containers , network - , streaming-commons >= 0.1.15 - , connection >= 0.2 + , streaming-commons + , connection , websockets + , network-conduit-tls default-language: Haskell2010