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
Download patch file Download diff file Expand all files Collapse all files

33
src/Protocols.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -21,6 +22,7 @@ import qualified Network.Socket as N hiding (recv, recvFrom, send,
sendTo)
import qualified Network.Socket.ByteString as N
import qualified System.Log.Logger as LOG
deriving instance Generic 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)
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 (host, port) app = do
putStrLn $ "WAIT for connection on " <> fromString host <> ":" <> tshow port
runTCPServer endPoint@(host, port) app = do
info $ "WAIT for tcp connection on " <> toStr endPoint
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 (host, port) app = do
putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port
runTCPClient endPoint@(host, port) app = do
info $ "CONNECTING to " <> toStr endPoint
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 (host, port) app = do
putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port
runUDPClient endPoint@(host, port) app = do
info $ "SENDING datagrammes to " <> toStr endPoint
bracket (N.getSocketUDP host (fromIntegral port)) (N.close . fst) $ \(socket, addrInfo) -> do
sem <- newEmptyMVar
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)
}
putStrLn $ "CLOSE connection to " <> fromString host <> ":" <> tshow port
info $ "CLOSE udp connection to " <> toStr endPoint
runUDPServer :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPServer (host, port) app = do
putStrLn $ "WAIT for datagrames on " <> fromString host <> ":" <> tshow port
runUDPServer endPoint@(host, port) app = do
info $ "WAIT for datagrames on " <> toStr endPoint
clientsCtx <- newIORef mempty
void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx)
putStrLn "CLOSE tunnel"
info $ "CLOSE udp server" <> toStr endPoint
where
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 clientsCtx clientCtx = do
void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ()))
putStrLn "TIMEOUT connection"
debug "TIMEOUT connection"
pushDataToClient :: UdpAppData -> ByteString -> IO ()
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 Network.Socket (HostName, PortNumber)
import qualified Network.Socket.ByteString as N
import qualified Network.Socket as N hiding (recv, recvFrom,
send, sendTo)
import qualified Network.Socket.ByteString as N
import qualified Network.WebSockets 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 cfg app = bracket
(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
{ read = Just <$> N.safeRecv s (N.getReadBufferSize cfg)
, write = N.sendAll s
@ -140,7 +140,6 @@ tunnelingClientP cfg@TunnelSettings{..} app conn = do
onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e)
tlsClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ()))
tlsClientP TunnelSettings{..} app conn = do
let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
@ -245,14 +244,14 @@ runClient cfg@TunnelSettings{..} = do
handleError :: Either Error () -> IO ()
handleError (Right ()) = return ()
handleError (Left err) =
case err of
ProxyConnectionError msg -> info "Cannot connect to the proxy" >> debugPP msg
ProxyForwardError msg -> info "Connection not allowed by the proxy" >> debugPP msg
TunnelError msg -> info "Cannot establish the connection to the server" >> debugPP msg
LocalServerError msg -> info "Cannot create the localServer, port already binded ?" >> debugPP msg
WebsocketError msg -> info "Cannot establish websocket connection with the server" >> debugPP msg
TlsError msg -> info "Cannot do tls handshake with the server" >> debugPP msg
handleError (Left errMsg) =
case errMsg of
ProxyConnectionError msg -> err "Cannot connect to the proxy" >> debugPP msg
ProxyForwardError msg -> err "Connection not allowed by the proxy" >> debugPP msg
TunnelError msg -> err "Cannot establish the connection to the server" >> debugPP msg
LocalServerError msg -> err "Cannot create the localServer, port already binded ?" >> debugPP msg
WebsocketError msg -> err "Cannot establish websocket connection with the server" >> debugPP msg
TlsError msg -> err "Cannot do tls handshake with the server" >> debugPP msg
Other msg -> debugPP msg
where
@ -382,6 +381,3 @@ fromPath path = let rets = BC.split '/' . BC.drop 1 $ path
prt' <- readMay . BC.unpack $ prt :: Maybe Int
proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol
return (proto, h, prt')
info = LOG.infoM "wstunnel"
debug = LOG.debugM "wstunnel"