Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
90 lines (85 sloc) 2.75 KB
;;; -*- Gerbil -*-
;;; (C) vyzo at
;;; transparent TCP proxy
(import :gerbil/gambit/threads
(export main)
(def (run local remote)
(let* ((laddr (socket-address local))
(raddr (socket-address remote))
(caddr (make-socket-address (socket-address-family laddr)))
(sock (server-socket (socket-address-family laddr) SOCK_STREAM)))
(socket-setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
(socket-bind sock laddr)
(socket-listen sock 10)
(while #t
(wait (fd-io-in sock))
(let (cli (socket-accept sock caddr))
(when cli
(debug "Accepted connection from ~a" (socket-address->string caddr))
(spawn proxy cli raddr)))
(catch (e)
(log-error "Error accepting connection" e))))))
(def (proxy clisock raddr)
(let* ((srvsock (socket (socket-address-family raddr) SOCK_STREAM))
(rcon (socket-connect srvsock raddr)))
(unless rcon
(wait (fd-io-out srvsock)))
(let (r (or rcon (socket-getsockopt srvsock SOL_SOCKET SO_ERROR)))
(unless (fxzero? r)
(error (format "Connection error: ~a" (strerror r))))
(spawn proxy-io clisock srvsock)
(spawn proxy-io srvsock clisock)))
(catch (e)
(log-error "Error creating proxy" e))))
(def (proxy-io isock osock)
(def buf (make-u8vector 4096))
(let lp ()
(let (rd (socket-recv isock buf))
((not rd)
(wait (fd-io-in isock))
((fxzero? rd)
(close-input-port isock)
(socket-shutdown osock SHUT_WR))
(let (end rd)
(let lp2 ((start 0))
(if (fx< start end)
(let (wr (try (socket-send osock buf start end)
(catch (e)
(socket-shutdown isock SHUT_RD)
(raise e))))
((not wr)
(wait (fd-io-out osock))
(lp2 start))
(lp2 (fx+ start wr)))))
(catch (e)
(log-error "Error proxying connection" e)
(close-input-port isock)
(close-output-port osock))))
(def (main . args)
(def gopt
(getopt (argument 'local help: "local address to bind")
(argument 'remote help: "remote address to proxy to")))
(let (opt (getopt-parse gopt args))
(run (hash-get opt 'local) (hash-get opt 'remote)))
(catch (getopt-error? exn)
(getopt-display-help exn "tcp-proxy" (current-error-port))
(exit 1))))