Maj logging + Add quiet mode
This commit is contained in:
Erèbe
parent
42ae84a0ae
commit
1921d7d03a
3 changed files with 38 additions and 28 deletions
|
|
@ -16,12 +16,14 @@ import qualified System.Log.Logger as LOG
|
|||
data WsTunnel = WsTunnel
|
||||
{ localToRemote :: String
|
||||
-- , remoteToLocal :: String
|
||||
-- , dynamicToRemote :: String
|
||||
, wsTunnelServer :: String
|
||||
, udpMode :: Bool
|
||||
, proxy :: String
|
||||
, serverMode :: Bool
|
||||
, restrictTo :: String
|
||||
, verbose :: Bool
|
||||
, quiet :: Bool
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
data WsServerInfo = WsServerInfo
|
||||
|
|
@ -54,6 +56,7 @@ cmdLine = WsTunnel
|
|||
, restrictTo = def &= explicit &= name "r" &= name "restrictTo"
|
||||
&= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT"
|
||||
, 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"
|
||||
++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n"
|
||||
++ "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
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue