From abefd9cb44487ffc8eb575a4ef8402d076c58e9c Mon Sep 17 00:00:00 2001
From: Romain GERARD <r.gerard@criteo.com>
Date: Sun, 26 Apr 2020 14:34:41 +0200
Subject: [PATCH]  #41 Add logging info when new ip connect to the server

 + 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
---
 Setup.hs      |  2 --
 src/Tunnel.hs | 12 +++++++-----
 src/Types.hs  |  2 +-
 3 files changed, 8 insertions(+), 8 deletions(-)
 delete mode 100644 Setup.hs

diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/src/Tunnel.hs b/src/Tunnel.hs
index 035432b..5451010 100644
--- a/src/Tunnel.hs
+++ b/src/Tunnel.hs
@@ -46,7 +46,7 @@ rrunTCPClient cfg app = bracket
       N.setSocketOption s N.RecvBuffer defaultRecvBufferSize
       N.setSocketOption s N.SendBuffer defaultSendBufferSize
       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)
     )
     (\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
 
   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"
 
@@ -209,7 +209,7 @@ runTunnelingServer endPoint@(host, port) isAllowed = do
   let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
   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)
-    runApp stream WS.defaultConnectionOptions (serverEventLoop isAllowed)
+    runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
 
   info "CLOSE server"
 
@@ -218,9 +218,11 @@ runTunnelingServer endPoint@(host, port) isAllowed = do
     runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts)
                          (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
 
-serverEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
-serverEventLoop isAllowed pendingConn = do
+serverEventLoop :: N.SockAddr -> ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
+serverEventLoop sClient isAllowed pendingConn = do
   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
     Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
     Just (!proto, !rhost, !rport) ->
diff --git a/src/Types.hs b/src/Types.hs
index 6ee8c76..f3007c7 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -36,7 +36,7 @@ defaultSendBufferSize :: Int
 defaultSendBufferSize = defaultRecvBufferSize
 
 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 #-}
 sO_MARK_Value :: IORef Int