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

#41 Add logging info when new ip connect to the server

Browse source 
+ Some linting fix


Former-commit-id: 78e8ad13287c3916dc363da0c20276937cd083bd
Former-commit-id: ef5e19d8f30f5038f96dadd7cfe344fbb4cbe842 [formerly 4fced1a153baaec01acdb9089be7347a4fdf7cd8] [formerly 43b403240f46e616637d11243b96793c0eca9ed7 [formerly 35aeae9b41abbedfd81b5b2f7de6609408536443 [formerly 35aeae9b41abbedfd81b5b2f7de6609408536443 [formerly 35aeae9b41abbedfd81b5b2f7de6609408536443 [formerly 5e7680c129ca27d9cf0aea32c56f5262aa187103]]]]]
Former-commit-id: 29c1b6ff7b1edc6ad066c5bf49c5e5d3f1dae524 [formerly 703efc9ce2bd6177b724ec5316d499f5a003e46a]
Former-commit-id: e4421ee34439ef05d1b1d4d6ca8daef8a256ed40
Former-commit-id: 69affb2d201ad218877e4226bf7f73bae04b25c3
Former-commit-id: a98a68f3939a0fe69b86c5a5704619e6eb84a3c8
Former-commit-id: 32ef81a31fb98402f19bdf10100b64bdc6a26f45 [formerly 7efac6c472c9ff67bbdab69e746e25027ab355f6]
Former-commit-id: 00fb5058bc3b013464ca82a19cae3e4dc29b89c3
This commit is contained in:
Romain GERARD 2020-04-26 14:34:41 +02:00
parent 71019e413b
commit abefd9cb44
3 changed files with 8 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

12
src/Tunnel.hs
View file

@ -46,7 +46,7 @@ rrunTCPClient cfg app = bracket
N.setSocketOption s N.RecvBuffer defaultRecvBufferSize N.setSocketOption s N.RecvBuffer defaultRecvBufferSize
N.setSocketOption s N.SendBuffer defaultSendBufferSize N.setSocketOption s N.SendBuffer defaultSendBufferSize
so_mark_val <- readIORef sO_MARK_Value so_mark_val <- readIORef sO_MARK_Value
_ <- when (so_mark_val /= 0 && N.isSupportedSocketOption sO_MARK) (N.setSocketOption s sO_MARK so_mark_val) when (so_mark_val /= 0 && N.isSupportedSocketOption sO_MARK) (N.setSocketOption s sO_MARK so_mark_val)
return (s,addr) return (s,addr)
) )
(\r -> catch (N.close $ fst r) (\(_ :: SomeException) -> return ())) (\r -> catch (N.close $ fst r) (\(_ :: SomeException) -> return ()))
@ -190,7 +190,7 @@ runTlsTunnelingServer endPoint@(bindTo, portNumber) isAllowed = do
info $ "WAIT for TLS connection on " <> toStr endPoint info $ "WAIT for TLS connection on " <> toStr endPoint
N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) Credentials.certificate Credentials.key) $ \sClient -> N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) Credentials.certificate Credentials.key) $ \sClient ->
runApp sClient WS.defaultConnectionOptions (serverEventLoop isAllowed) runApp sClient WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
info "SHUTDOWN server" info "SHUTDOWN server"
@ -209,7 +209,7 @@ runTunnelingServer endPoint@(host, port) isAllowed = do
let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host) let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
void $ N.runTCPServer srvSet $ \sClient -> do void $ N.runTCPServer srvSet $ \sClient -> do
stream <- WS.makeStream (N.appRead sClient <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite sClient . toStrict . fromJust) stream <- WS.makeStream (N.appRead sClient <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite sClient . toStrict . fromJust)
runApp stream WS.defaultConnectionOptions (serverEventLoop isAllowed) runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
info "CLOSE server" info "CLOSE server"
@ -218,9 +218,11 @@ runTunnelingServer endPoint@(host, port) isAllowed = do
runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts) runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts)
(\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ())) (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
serverEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO () serverEventLoop :: N.SockAddr -> ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
serverEventLoop isAllowed pendingConn = do serverEventLoop sClient isAllowed pendingConn = do
let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn
let forwardedFor = filter (\(header,val) -> header == "x-forwarded-for") $ WS.requestHeaders $ WS.pendingRequest pendingConn
info $ "NEW incoming connection from " <> show sClient <> " " <> show forwardedFor
case path of case path of
Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information" Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
Just (!proto, !rhost, !rport) -> Just (!proto, !rhost, !rport) ->

2
src/Types.hs
View file

@ -36,7 +36,7 @@ defaultSendBufferSize :: Int
defaultSendBufferSize = defaultRecvBufferSize defaultSendBufferSize = defaultRecvBufferSize
sO_MARK :: N.SocketOption sO_MARK :: N.SocketOption
sO_MARK = N.CustomSockOpt (fromIntegral 1, fromIntegral 36) -- https://elixir.bootlin.com/linux/latest/source/arch/alpha/include/uapi/asm/socket.h#L64 sO_MARK = N.CustomSockOpt (1, 36) -- https://elixir.bootlin.com/linux/latest/source/arch/alpha/include/uapi/asm/socket.h#L64
{-# NOINLINE sO_MARK_Value #-} {-# NOINLINE sO_MARK_Value #-}
sO_MARK_Value :: IORef Int sO_MARK_Value :: IORef Int