#!/usr/bin/env racket
#lang racket ; -*- scheme -*-

;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

(define max-listeners 20)
(define reuse-port? #t)

;;=============================================================================
;; Utilities

(define (eprintf fmt . args) (apply fprintf (current-error-port) fmt args))

(define (error-exit fmt . args)
  (apply eprintf fmt args) (exit 1))

(uncaught-exception-handler
 (lambda (e)
   (if (exn:break? e)
     (error-exit "Bye.\n")
     (error-exit "ERROR: ~a\n" (if (exn? e) (exn-message e) e)))))

(define (tcp-listen-retry port)
  (let loop ([s 1])
    (let ([x (with-handlers ([exn:fail:network? (lambda (x) x)])
               (tcp-listen port max-listeners reuse-port?))])
      (cond [(tcp-listener? x) x]
            [(regexp-match "Address already in use" (exn-message x))
             (eprintf "Port ~a is busy, sleeping ~a seconds...\n" port s)
             (sleep s)
             (loop (add1 s))]
            [else (raise x)]))))

(define (tcp-try-connect host port)
  (with-handlers ([exn:fail:network? (lambda (e) (values #f #f))])
    (tcp-connect host port)))

;;=============================================================================
;; Configuration vars (from command line)

(define *lport* #f)
(define *rhost* #f)
(define *rport* #f)
(define *init-cmds* #f)

(define *bufsize* 1024)

(let ([args (vector->list (current-command-line-arguments))])
  (when (<= 3 (length args))
    (set! *lport* (string->number (car args)))
    (set! *rhost* (cadr args))
    (set! *rport* (string->number (caddr args)))
    (set! *init-cmds* (string-join (cdddr args)))))

(unless (and *lport* *rport* (not (equal? "" *rhost*)))
  (error-exit "Expecting <local-port> <remote-host> <remote-port> [cmd ...]\n"))

;;=============================================================================
;; Delay control etc

(define *delay* 1)
(define *connection-delay* 1)
(define *verbose* 0)
(define *monitor?* #f)
(define *monitor-factor* 1)

(define main-thread (current-thread))

(define (input-control)
  (define (line str . args) (printf ">>> ~a\n" (apply format str args)))
  (printf "Controler waiting, `h' for help.\n")
  (let loop ([l (and *init-cmds* (begin0 *init-cmds* (set! *init-cmds* #f)))])
    (let ([l (or l (read-line))])
      (if (string? l)
        (let* ([m    (regexp-match #rx"^ *([a-zA-Z]+)? *([0-9]+)? *(.+)?$" l)]
               [cmd  (and (cadr m) (string->symbol (cadr m)))]
               [arg  (and (caddr m) (string->number (caddr m)))]
               [rest (and (or (cadr m) (caddr m)) (cadddr m))])
          (case cmd
            [(h he hel help ?)
             (line "Commands:")
             (line "  h/help    - this text")
             (line "  vN        - set verbosity (0=none, 1=normal, 2=show-io)")
             (line "  dN        - set delay")
             (line "  cN        - set connection delay")
             (line "  monitor   - toggle i/o monitoring using beep")
             (line "  mN        - set monitor sensitivity")
             (line "  quit/exit - quit (same as ctrl+c)")
             (line "Delay is ~s" *delay*)
             (line "Connection delay is ~s" *connection-delay*)
             (line "Verbosity is ~a" *verbose*)
             (line "Monitor is ~a (sens=~a)"
                   (if *monitor?* "on" "off") *monitor-factor*)]
            [(q qu qui quit
              e ex exi exit)
             (break-thread main-thread)]
            [(mo mon moni monit monito monitor)
             (set! *monitor?* (if arg (not (zero? arg)) (not *monitor?*)))
             (line "Monitor set to ~a" (if *monitor?* "on" "off"))]
            [(v)
             (when arg (set! *verbose* arg))
             (line "Verbosity set to ~s" *verbose*)]
            [(d)
             (when arg (set! *delay* arg))
             (line "Delay set to ~s" *delay*)]
            [(c)
             (when arg (set! *connection-delay* arg))
             (line "Connection delay set to ~s" *connection-delay*)]
            [(m)
             (if arg
               (begin (set! *monitor-factor* arg) (set! *monitor?* (< 0 arg)))
               (set! *monitor?* (not *monitor?*)))
             (line "Monitor is ~a, sensitivity set to ~s"
                   (if *monitor?* "on" "off") *monitor-factor*)]
            [else (line "Unknown input, type `h' for help")])
          (loop rest))
        (line "Input control done.")))))

;;=============================================================================
;; Net traffic

(define avg-i/o 0.0)
(define last-monitor-call (current-inexact-milliseconds))
(define monitored-size 0)
(define monitor-sema (make-semaphore 1))

(define beep-exe (find-executable-path "beep" #f))
(define (beep freq len)
  (when (and (< 1 freq) (< 1 len))
    (subprocess (current-output-port) (current-input-port) (current-error-port)
                beep-exe "-f" (number->string freq) "-l" (number->string len))))

(define (monitor-block size)
  (semaphore-wait monitor-sema)
  (set! monitored-size (+ monitored-size size))
  (semaphore-post monitor-sema))

(define (monitor)
  (when *monitor?*
    (semaphore-wait monitor-sema)
    (let* ([cur   (current-inexact-milliseconds)]
           [delta (- cur last-monitor-call)]
           [size  monitored-size])
      (set! last-monitor-call cur)
      (set! monitored-size 0)
      (semaphore-post monitor-sema)
      (set! avg-i/o (+ (* 0.8 avg-i/o) (* 0.2 (/ size delta))))
      (printf "avg-i/o: ~s\n" avg-i/o)
      (beep (* avg-i/o 10 *monitor-factor*) 100)))
  (sleep 1)
  (monitor))
(void (thread monitor))

(define (cat name i o)
  (let* ([bufsize *bufsize*] [buf (make-bytes bufsize)] [len 0]
         [sleeplen bufsize])
    (define (loop)
      (let ([l (read-bytes-avail! buf i 0 bufsize)])
        (unless (eof-object? l)
          (set! len (+ l len))
          (when (<= 1 *verbose*)
            (printf "~a: Packet size = ~s [~s]\n" name l len)
            (when (<= 2 *verbose*)
              (printf ">>>>>> ~s\n" (if (< l bufsize) (subbytes buf 0 l) buf))))
          (when *monitor?* (monitor-block l))
          ;; (printf "~s\n" (if (< l bufsize) (subbytes buf 0 l) buf))
          (display (if (< l bufsize) (subbytes buf 0 l) buf) o)
          (when (< sleeplen len)
            (sleep (/ *delay* 1000.0))
            (set! sleeplen (+ sleeplen bufsize)))
          (loop))))
    (lambda ()
      (with-handlers ([void (lambda (e)
                              (printf "~a: Aborting cat: ~s.\n"
                                       name (if (exn? e) (exn-message e) e)))])
        (loop))
      (close-input-port i) (close-output-port o)
      (printf "~a: Done, total: ~s\n" name len))))

(define (server)
  (define listener (tcp-listen-retry *lport*))
  (define num 0)
  (printf "Started: localhost:~a -> ~a:~a.\n" *lport* *rhost* *rport*)
  (thread input-control)
  (let loop ()
    (let-values ([(li lo) (tcp-accept listener)]
                 [(ri ro) (tcp-try-connect *rhost* *rport*)])
      (if (and li lo ri ro)
        (begin (set! num (add1 num))
               (printf "Connection #~a started.\n" num)
               (sleep (/ *connection-delay* 1000.0))
               (file-stream-buffer-mode ro 'none)
               (file-stream-buffer-mode lo 'none)
               (thread (cat (format "#~a L->R" num) li ro))
               (thread (cat (format "#~a R->L" num) ri lo)))
        (begin (eprintf "Couldn't connect to ~a:~a.\n" *rhost* *rport*)
               (close-input-port li) (close-output-port lo))))
    (loop)))

;;=============================================================================
;; Main

(server)