#!/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 [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)