Add tls server

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))

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
+runServerEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
-     let path =  fromPath . WS.requestPath $ WS.pendingRequest pendingConn
+runServerEventLoop isAllowed pendingConn = do
-     case path of
+  let path =  fromPath . WS.requestPath $ WS.pendingRequest pendingConn
-       Nothing -> putStrLn "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
+  case path of
-       Just (!proto, !rhost, !rport) ->
+    Nothing -> putStrLn "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
-         if not $ isAllowed (rhost, rport)
+    Just (!proto, !rhost, !rport) ->
-         then do
+      if not $ isAllowed (rhost, rport)
-           putStrLn "Rejecting tunneling"
+      then do
-           WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling"
+        putStrLn "Rejecting tunneling"
-         else do
+        WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling"
-           conn <- WS.acceptRequest pendingConn
+      else do
-           case proto of
+        conn <- WS.acceptRequest pendingConn
-             UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn)
+        case proto of
-             TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (propagateRW conn)
+          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 :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
-runServer = runTunnelingServer
+runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer
 
 
 runTlsTunnelingClient :: Proto -> (HostName, PortNumber) -> (HostName, PortNumber) -> (WS.Connection -> IO ()) -> IO ()

stack.yaml

@@ -1,13 +1,44 @@
-# This file was automatically generated by stack init
+# This file was automatically generated by 'stack init'
-# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
+# 
+# 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 to choose a 'specific' stackage snapshot or a compiler version.
-resolver: lts-5.16
+# 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

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
+                     , streaming-commons
-                     , connection >= 0.2
+                     , connection
                      , websockets
+                     , network-conduit-tls
 
   default-language:    Haskell2010