hex/wstunnel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Maj logging + Add quiet mode

Browse source
This commit is contained in:
Erèbe 2016-06-01 22:01:23 +02:00
parent 42ae84a0ae
commit 1921d7d03a
3 changed files with 38 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
app/Main.hs
View file

@ -16,12 +16,14 @@ import qualified System.Log.Logger as LOG
data WsTunnel = WsTunnel data WsTunnel = WsTunnel
{ localToRemote :: String { localToRemote :: String
-- , remoteToLocal :: String -- , remoteToLocal :: String
-- , dynamicToRemote :: String
, wsTunnelServer :: String , wsTunnelServer :: String
, udpMode :: Bool , udpMode :: Bool
, proxy :: String , proxy :: String
, serverMode :: Bool , serverMode :: Bool
, restrictTo :: String , restrictTo :: String
, verbose :: Bool , verbose :: Bool
, quiet :: Bool
} deriving (Show, Data, Typeable) } deriving (Show, Data, Typeable)
data WsServerInfo = WsServerInfo data WsServerInfo = WsServerInfo
@ -54,6 +56,7 @@ cmdLine = WsTunnel
, restrictTo = def &= explicit &= name "r" &= name "restrictTo" , restrictTo = def &= explicit &= name "r" &= name "restrictTo"
&= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT" &= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT"
, verbose = def &= groupname "Common options" &= help "Print debug information" , verbose = def &= groupname "Common options" &= help "Print debug information"
, quiet = def &= help "Print only errors"
} &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n" } &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n"
++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n" ++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n"
++ "Use secure connection (wss://) to bypass proxies" ++ "Use secure connection (wss://) to bypass proxies"
@ -106,7 +109,11 @@ main = do
cfg <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine cfg <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine
let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg) let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg)
LOG.updateGlobalLogger "wstunnel" (if verbose cfg then LOG.setLevel LOG.DEBUG else LOG.setLevel LOG.INFO) LOG.updateGlobalLogger "wstunnel" (if quiet cfg
then LOG.setLevel LOG.ERROR
else if verbose cfg
then LOG.setLevel LOG.DEBUG
else LOG.setLevel LOG.INFO)
if serverMode cfg if serverMode cfg

33
src/Protocols.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -21,6 +22,7 @@ import qualified Network.Socket as N hiding (recv, recvFrom, send,
sendTo) sendTo)
import qualified Network.Socket.ByteString as N import qualified Network.Socket.ByteString as N
import qualified System.Log.Logger as LOG
deriving instance Generic PortNumber deriving instance Generic PortNumber
deriving instance Hashable PortNumber deriving instance Hashable PortNumber
@ -41,24 +43,29 @@ instance N.HasReadWrite UdpAppData where
readLens f appData = fmap (\getData -> appData { appRead = getData}) (f $ appRead appData) readLens f appData = fmap (\getData -> appData { appRead = getData}) (f $ appRead appData)
writeLens f appData = fmap (\writeData -> appData { appWrite = writeData}) (f $ appWrite appData) writeLens f appData = fmap (\writeData -> appData { appWrite = writeData}) (f $ appWrite appData)
toStr :: (HostName, PortNumber) -> String
toStr (host, port) = fromString host <> ":" <> show port
err msg = LOG.errorM "wstunnel" $ "ERROR :: " <> msg
info = LOG.infoM "wstunnel"
debug msg = LOG.debugM "wstunnel" $ "DEBUG :: " <> msg
runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO () runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
runTCPServer (host, port) app = do runTCPServer endPoint@(host, port) app = do
putStrLn $ "WAIT for connection on " <> fromString host <> ":" <> tshow port info $ "WAIT for tcp connection on " <> toStr endPoint
void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) app void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) app
putStrLn "CLOSE tunnel" info $ "CLOSE tcp server on " <> toStr endPoint
runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO () runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
runTCPClient (host, port) app = do runTCPClient endPoint@(host, port) app = do
putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port info $ "CONNECTING to " <> toStr endPoint
void $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (BC.pack host)) app void $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (BC.pack host)) app
putStrLn $ "CLOSE connection to " <> fromString host <> ":" <> tshow port info $ "CLOSE connection to " <> toStr endPoint
runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO () runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPClient (host, port) app = do runUDPClient endPoint@(host, port) app = do
putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port info $ "SENDING datagrammes to " <> toStr endPoint
bracket (N.getSocketUDP host (fromIntegral port)) (N.close . fst) $ \(socket, addrInfo) -> do bracket (N.getSocketUDP host (fromIntegral port)) (N.close . fst) $ \(socket, addrInfo) -> do
sem <- newEmptyMVar sem <- newEmptyMVar
app UdpAppData { appAddr = N.addrAddress addrInfo app UdpAppData { appAddr = N.addrAddress addrInfo
@ -67,15 +74,15 @@ runUDPClient (host, port) app = do
, appWrite = \payload -> void $ N.sendTo socket payload (N.addrAddress addrInfo) , appWrite = \payload -> void $ N.sendTo socket payload (N.addrAddress addrInfo)
} }
putStrLn $ "CLOSE connection to " <> fromString host <> ":" <> tshow port info $ "CLOSE udp connection to " <> toStr endPoint
runUDPServer :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO () runUDPServer :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPServer (host, port) app = do runUDPServer endPoint@(host, port) app = do
putStrLn $ "WAIT for datagrames on " <> fromString host <> ":" <> tshow port info $ "WAIT for datagrames on " <> toStr endPoint
clientsCtx <- newIORef mempty clientsCtx <- newIORef mempty
void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx) void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx)
putStrLn "CLOSE tunnel" info $ "CLOSE udp server" <> toStr endPoint
where where
addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData
@ -92,7 +99,7 @@ runUDPServer (host, port) app = do
removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO () removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO ()
removeClient clientsCtx clientCtx = do removeClient clientsCtx clientCtx = do
void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ())) void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ()))
putStrLn "TIMEOUT connection" debug "TIMEOUT connection"
pushDataToClient :: UdpAppData -> ByteString -> IO () pushDataToClient :: UdpAppData -> ByteString -> IO ()
pushDataToClient clientCtx = putMVar (appSem clientCtx) pushDataToClient clientCtx = putMVar (appSem clientCtx)

24
src/Tunnel.hs
View file

@ -23,9 +23,9 @@ import qualified Data.Conduit.Network.TLS as N
import qualified Data.Streaming.Network as N import qualified Data.Streaming.Network as N
import Network.Socket (HostName, PortNumber) import Network.Socket (HostName, PortNumber)
import qualified Network.Socket.ByteString as N
import qualified Network.Socket as N hiding (recv, recvFrom, import qualified Network.Socket as N hiding (recv, recvFrom,
send, sendTo) send, sendTo)
import qualified Network.Socket.ByteString as N
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified Network.WebSockets.Connection as WS import qualified Network.WebSockets.Connection as WS
@ -113,7 +113,7 @@ instance ToConnection NC.Connection where
rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient cfg app = bracket rrunTCPClient cfg app = bracket
(N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)) (N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg))
(\r -> catch (N.sClose $ fst r) (\(e :: SomeException) -> return ())) (\r -> catch (N.sClose $ fst r) (\(_ :: SomeException) -> return ()))
(\(s, _) -> app Connection (\(s, _) -> app Connection
{ read = Just <$> N.safeRecv s (N.getReadBufferSize cfg) { read = Just <$> N.safeRecv s (N.getReadBufferSize cfg)
, write = N.sendAll s , write = N.sendAll s
@ -140,7 +140,6 @@ tunnelingClientP cfg@TunnelSettings{..} app conn = do
onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e) onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e)
tlsClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ())) tlsClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ()))
tlsClientP TunnelSettings{..} app conn = do tlsClientP TunnelSettings{..} app conn = do
let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
@ -245,14 +244,14 @@ runClient cfg@TunnelSettings{..} = do
handleError :: Either Error () -> IO () handleError :: Either Error () -> IO ()
handleError (Right ()) = return () handleError (Right ()) = return ()
handleError (Left err) = handleError (Left errMsg) =
case err of case errMsg of
ProxyConnectionError msg -> info "Cannot connect to the proxy" >> debugPP msg ProxyConnectionError msg -> err "Cannot connect to the proxy" >> debugPP msg
ProxyForwardError msg -> info "Connection not allowed by the proxy" >> debugPP msg ProxyForwardError msg -> err "Connection not allowed by the proxy" >> debugPP msg
TunnelError msg -> info "Cannot establish the connection to the server" >> debugPP msg TunnelError msg -> err "Cannot establish the connection to the server" >> debugPP msg
LocalServerError msg -> info "Cannot create the localServer, port already binded ?" >> debugPP msg LocalServerError msg -> err "Cannot create the localServer, port already binded ?" >> debugPP msg
WebsocketError msg -> info "Cannot establish websocket connection with the server" >> debugPP msg WebsocketError msg -> err "Cannot establish websocket connection with the server" >> debugPP msg
TlsError msg -> info "Cannot do tls handshake with the server" >> debugPP msg TlsError msg -> err "Cannot do tls handshake with the server" >> debugPP msg
Other msg -> debugPP msg Other msg -> debugPP msg
where where
@ -382,6 +381,3 @@ fromPath path = let rets = BC.split '/' . BC.drop 1 $ path
prt' <- readMay . BC.unpack $ prt :: Maybe Int prt' <- readMay . BC.unpack $ prt :: Maybe Int
proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol
return (proto, h, prt') return (proto, h, prt')
info = LOG.infoM "wstunnel"
debug = LOG.debugM "wstunnel"