1#!/usr/bin/env perl
2#
3# Copyright (c) 2009-2010 by Karl J. Runge <runge@karlrunge.com>
4#
5# ultravnc_repeater.pl is free software; you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation; either version 2 of the License, or (at
8# your option) any later version.
9#
10# ultravnc_repeater.pl is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License
16# along with ultravnc_repeater.pl; if not, write to the Free Software
17# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA
18# or see <http://www.gnu.org/licenses/>.
19#
20
21my $usage = '
22ultravnc_repeater.pl:
23          perl script implementing the ultravnc repeater
24          proxy protocol.
25
26protocol: Listen on one port for vnc clients (default 5900.)
27          Listen on one port for vnc servers (default 5500.)
28          Read 250 bytes from connecting vnc client or server.
29          Accept ID:<string> from clients and servers, connect them
30          together once both are present.
31
32          The string "RFB 000.000\n" is sent to the client (the client
33          must understand this means send ID:... or host:port.)
34          Also accept <host>:<port> from clients and make the
35          connection to the vnc server immediately.
36
37          Note there is no authentication or security WRT ID names or
38          identities; it is up to the client and server to completely
39          manage that aspect and whether to encrypt the session, etc.
40
41usage:  ultravnc_repeater.pl [-r] [client_port [server_port]]
42
43Use -r to refuse new server/client connections when there is an existing
44server/client ID.  The default is to close the previous one.
45
46To write to a log file set the env. var ULTRAVNC_REPEATER_LOGFILE.
47
48To run in a loop restarting the server if it exits set the env. var.
49ULTRAVNC_REPEATER_LOOP=1 or ULTRAVNC_REPEATER_LOOP=BG, the latter
50forks into the background.  Set ULTRAVNC_REPEATER_PIDFILE to a file
51to store the master pid in.
52
53Set ULTRAVNC_REPEATER_NO_RFB=1 to disable sending "RFB 000.000" to
54the client.  Then this program acts as general TCP rendezvous tool.
55
56Examples:
57
58	ultravnc_repeater.pl
59	ultravnc_repeater.pl -r
60	ultravnc_repeater.pl 5901
61	ultravnc_repeater.pl 5901 5501
62
63	env ULTRAVNC_REPEATER_LOOP=BG ULTRAVNC_REPEATER_LOGFILE=/tmp/u.log ultravnc_repeater.pl ...
64
65';
66
67use strict;
68
69# Set up logging:
70#
71if (exists $ENV{ULTRAVNC_REPEATER_LOGFILE}) {
72	close STDOUT;
73	if (!open(STDOUT, ">>$ENV{ULTRAVNC_REPEATER_LOGFILE}")) {
74	        die "ultravnc_repeater.pl: $ENV{ULTRAVNC_REPEATER_LOGFILE} $!\n";
75	}
76	close STDERR;
77	open(STDERR, ">&STDOUT");
78}
79select(STDERR); $| = 1;
80select(STDOUT); $| = 1;
81
82# interrupt handler:
83#
84my $looppid = '';
85my $pidfile = '';
86#
87sub get_out {
88	lprint("$_[0]:\t$$ looppid=$looppid");
89	if ($looppid) {
90		kill 'TERM', $looppid;
91		fsleep(0.2);
92	}
93	unlink $pidfile if $pidfile;
94	cleanup();
95	exit 0;
96}
97
98sub lprint {
99	print STDERR scalar(localtime), ": ", @_, "\n";
100}
101
102# These are overridden in actual server thread:
103#
104$SIG{INT}  = \&get_out;
105$SIG{TERM} = \&get_out;
106
107# pidfile:
108#
109sub open_pidfile {
110	if (exists $ENV{ULTRAVNC_REPEATER_PIDFILE}) {
111		my $pf = $ENV{ULTRAVNC_REPEATER_PIDFILE};
112		if (open(PID, ">$pf")) {
113			print PID "$$\n";
114			close PID;
115			$pidfile = $pf;
116		} else {
117			lprint("could not open pidfile: $pf - $! - continuing...");
118		}
119		delete $ENV{ULTRAVNC_REPEATER_PIDFILE};
120	}
121}
122
123####################################################################
124# Set ULTRAVNC_REPEATER_LOOP=1 to have this script create an outer loop
125# restarting itself if it ever exits.  Set ULTRAVNC_REPEATER_LOOP=BG to
126# do this in the background as a daemon.
127
128if (exists $ENV{ULTRAVNC_REPEATER_LOOP}) {
129	my $csl = $ENV{ULTRAVNC_REPEATER_LOOP};
130	if ($csl ne 'BG' && $csl ne '1') {
131		die "ultravnc_repeater.pl: invalid ULTRAVNC_REPEATER_LOOP.\n";
132	}
133	if ($csl eq 'BG') {
134		# go into bg as "daemon":
135		setpgrp(0, 0);
136		my $pid = fork();
137		if (! defined $pid) {
138			die "ultravnc_repeater.pl: $!\n";
139		} elsif ($pid) {
140			wait;
141			exit 0;
142		}
143		if (fork) {
144			exit 0;
145		}
146		setpgrp(0, 0);
147		close STDIN;
148		if (! $ENV{ULTRAVNC_REPEATER_LOGFILE}) {
149			close STDOUT;
150			close STDERR;
151		}
152	}
153	delete $ENV{ULTRAVNC_REPEATER_LOOP};
154
155	if (exists $ENV{ULTRAVNC_REPEATER_PIDFILE}) {
156		open_pidfile();
157	}
158
159	lprint("ultravnc_repeater.pl: starting service. master-pid=$$");
160	while (1) {
161		$looppid = fork;
162		if (! defined $looppid) {
163			sleep 10;
164		} elsif ($looppid) {
165			wait;
166		} else {
167			exec $0, @ARGV;
168			exit 1;
169		}
170		lprint("ultravnc_repeater.pl: re-starting service.  master-pid=$$");
171		sleep 1;
172	}
173	exit 0;
174}
175if (exists $ENV{ULTRAVNC_REPEATER_PIDFILE}) {
176	open_pidfile();
177}
178
179# End of background/daemon stuff.
180####################################################################
181
182use warnings;
183use IO::Socket::INET;
184use IO::Select;
185
186# Test for INET6 support:
187#
188my $have_inet6 = 0;
189eval "use IO::Socket::INET6;";
190$have_inet6 = 1 if $@ eq "";
191print "perl module IO::Socket::INET6 not available: no IPv6 support.\n" if ! $have_inet6;
192
193my $prog = 'ultravnc_repeater';
194my %ID;
195
196my $refuse = 0;
197my $init_timeout = 5;
198
199if (@ARGV && $ARGV[0] =~ /-h/) {
200	print $usage;
201	exit 0;
202}
203if (@ARGV && $ARGV[0] eq '-r') {
204	$refuse = 1;
205	lprint("enabling refuse mode (-r).");
206	shift;
207}
208
209my $client_port = shift;
210my $server_port = shift;
211
212$client_port = 5900 unless $client_port;
213$server_port = 5500 unless $server_port;
214
215my $uname = `uname`;
216
217my $repeater_bufsize = 250;
218$repeater_bufsize = $ENV{BUFSIZE} if exists $ENV{BUFSIZE};
219
220my ($RIN, $WIN, $EIN, $ROUT);
221
222my $client_listen = IO::Socket::INET->new(
223	Listen    => 10,
224	LocalPort => $client_port,
225	ReuseAddr => 1,
226	Proto => "tcp"
227);
228my $err1 = $!;
229my $err2 = '';
230$client_listen = '' if ! $client_listen;
231
232my $client_listen6 = '';
233if ($have_inet6) {
234	eval {$client_listen6 = IO::Socket::INET6->new(
235		Listen    => 10,
236		LocalPort => $client_port,
237		ReuseAddr => 1,
238		Domain    => AF_INET6,
239		LocalAddr => "::",
240		Proto     => "tcp"
241	);};
242	$err2 = $!;
243}
244if (! $client_listen && ! $client_listen6) {
245	cleanup();
246	die "$prog: error: client listen on port $client_port: $err1 - $err2\n";
247}
248
249my $server_listen = IO::Socket::INET->new(
250	Listen    => 10,
251	LocalPort => $server_port,
252	ReuseAddr => 1,
253	Proto => "tcp"
254);
255$err1 = $!;
256$err2 = '';
257$server_listen = '' if ! $server_listen;
258
259my $server_listen6 = '';
260if ($have_inet6) {
261	eval {$server_listen6 = IO::Socket::INET6->new(
262		Listen    => 10,
263		LocalPort => $server_port,
264		ReuseAddr => 1,
265		Domain    => AF_INET6,
266		LocalAddr => "::",
267		Proto     => "tcp"
268	);};
269	$err2 = $!;
270}
271if (! $server_listen && ! $server_listen6) {
272	cleanup();
273	die "$prog: error: server listen on port $server_port: $err1 - $err2\n";
274}
275
276my $select = new IO::Select();
277if (! $select) {
278	cleanup();
279	die "$prog: select $!\n";
280}
281
282$select->add($client_listen)  if $client_listen;
283$select->add($client_listen6) if $client_listen6;
284$select->add($server_listen)  if $server_listen;
285$select->add($server_listen6) if $server_listen6;
286
287$SIG{INT}  = sub {cleanup(); exit;};
288$SIG{TERM} = sub {cleanup(); exit;};
289
290my $SOCK1 = '';
291my $SOCK2 = '';
292my $CURR = '';
293
294lprint("$prog: starting up.  pid: $$");
295lprint("watching for IPv4 connections on $client_port/client.") if $client_listen;
296lprint("watching for IPv4 connections on $server_port/server.") if $server_listen;
297lprint("watching for IPv6 connections on $client_port/client.") if $client_listen6;
298lprint("watching for IPv6 connections on $server_port/server.") if $server_listen6;
299
300my $alarm_sock = '';
301my $got_alarm = 0;
302sub alarm_handler {
303	lprint("$prog: got sig alarm.");
304	if ($alarm_sock ne '') {
305		close $alarm_sock;
306	}
307	$alarm_sock = '';
308	$got_alarm = 1;
309}
310
311while (my @ready = $select->can_read()) {
312	foreach my $fh (@ready) {
313		if (($client_listen && $fh == $client_listen) || ($client_listen6 && $fh == $client_listen6)) {
314			lprint("new vnc client connecting.");
315		} elsif (($server_listen && $fh == $server_listen) || ($server_listen6 && $fh == $server_listen6)) {
316			lprint("new vnc server connecting.");
317		}
318		my $sock = $fh->accept();
319		if (! $sock) {
320			lprint("$prog: accept $!");
321			next;
322		}
323
324		if (($client_listen && $fh == $client_listen) || ($client_listen6 && $fh == $client_listen6)) {
325			if (exists $ENV{ULTRAVNC_REPEATER_NO_RFB} && $ENV{ULTRAVNC_REPEATER_NO_RFB}) {
326				lprint("ULTRAVNC_REPEATER_NO_RFB: not sending RFB 000.000");
327			} else {
328				my $str = "RFB 000.000\n";
329				my $len = length $str;
330				my $n = syswrite($sock, $str, $len, 0);
331				if ($n != $len) {
332					lprint("$prog: bad $str write: $n != $len $!");
333					close $sock;
334				}
335			}
336		}
337
338		my $buf = '';
339		my $size = $repeater_bufsize;
340		$size = 1024 unless $size;
341
342		$SIG{ALRM} = "alarm_handler";
343		$alarm_sock = $sock;
344		$got_alarm = 0;
345		alarm($init_timeout);
346		my $n = sysread($sock, $buf, $size);
347		alarm(0);
348
349		if ($got_alarm) {
350			lprint("$prog: read timed out: $!");
351		} elsif (! defined $n) {
352			lprint("$prog: read error: $!");
353		} elsif ($repeater_bufsize > 0 && $n != $size) {
354			lprint("$prog: short read $n != $size $!");
355			close $sock;
356		} elsif (($client_listen && $fh == $client_listen) || ($client_listen6 && $fh == $client_listen6)) {
357			do_new_client($sock, $buf);
358		} elsif (($server_listen && $fh == $server_listen) || ($server_listen6 && $fh == $server_listen6)) {
359			do_new_server($sock, $buf);
360		}
361	}
362}
363
364sub do_new_client {
365	my ($sock, $buf) = @_;
366
367	if ($buf =~ /^ID:(\w+)/) {
368		my $id = $1;
369		if (exists $ID{$id} && exists $ID{$id}{client} && $ID{$id}{client} eq "0") {
370			if (!established($ID{$id}{sock})) {
371				lprint("server socket for ID:$id is no longer established, closing it.");
372				close $ID{$id}{sock};
373				delete $ID{$id};
374			} else {
375				lprint("server socket for ID:$id is still established.");
376			}
377		}
378		if (exists $ID{$id}) {
379			if ($ID{$id}{client}) {
380				my $ref = $refuse;
381				if ($ref && !established($ID{$id}{sock})) {
382					lprint("socket for ID:$id is no longer established, closing it.");
383					$ref = 0;
384				}
385				if ($ref) {
386					lprint("refusing extra vnc client for ID:$id.");
387					close $sock;
388					return;
389				} else {
390					lprint("closing and deleting previous vnc client with ID:$id.");
391					close $ID{$id}{sock};
392
393					lprint("storing new vnc client with ID:$id.");
394					$ID{$id}{client} = 1;
395					$ID{$id}{sock} = $sock;
396				}
397			} else {
398				lprint("hooking up new vnc client with existing vnc server for ID:$id.");
399				my $sock2 = $ID{$id}{sock};
400				delete $ID{$id};
401				hookup($sock, $sock2, "ID:$id");
402			}
403		} else {
404			lprint("storing new vnc client with ID:$id.");
405			$ID{$id}{client} = 1;
406			$ID{$id}{sock} = $sock;
407		}
408	} else {
409		my $str = sprintf("%s", $buf);
410		$str =~ s/\s*$//g;
411		$str =~ s/\0*$//g;
412		my $host = '';
413		my $port = '';
414		if ($str =~ /^(.+):(\d+)$/) {
415			$host = $1;
416			$port = $2;
417		} else {
418			$host = $str;
419			$port = 5900;
420		}
421		if ($port < 0) {
422			my $pnew = -$port;
423			lprint("resetting port from $port to $pnew.");
424			$port = $pnew;
425		} elsif ($port < 200) {
426			my $pnew = $port + 5900;
427			lprint("resetting port from $port to $pnew.");
428			$port = $pnew;
429		}
430		lprint("making vnc client connection directly to vnc server host='$host' port='$port'.");
431		my $sock2 =  IO::Socket::INET->new(
432			PeerAddr => $host,
433			PeerPort => $port,
434			Proto => "tcp"
435		);
436		if (! $sock2 && $have_inet6) {
437			lprint("IPv4 connect error: $!, trying IPv6 ...");
438			eval{$sock2 = IO::Socket::INET6->new(
439				PeerAddr => $host,
440				PeerPort => $port,
441				Proto => "tcp"
442			);};
443			lprint("IPv6 connect error: $!") if !$sock2;
444		} else {
445			lprint("IPv4 connect error: $!") if !$sock2;
446		}
447		if (!$sock2) {
448			lprint("failed to connect to $host:$port.");
449			close $sock;
450			return;
451		}
452		hookup($sock, $sock2, "$host:$port");
453	}
454}
455
456sub do_new_server {
457	my ($sock, $buf) = @_;
458
459	if ($buf =~ /^ID:(\w+)/) {
460		my $id = $1;
461		my $store = 1;
462		if (exists $ID{$id} && exists $ID{$id}{client} && $ID{$id}{client} eq "1") {
463			if (!established($ID{$id}{sock})) {
464				lprint("client socket for ID:$id is no longer established, closing it.");
465				close $ID{$id}{sock};
466				delete $ID{$id};
467			} else {
468				lprint("client socket for ID:$id is still established.");
469			}
470		}
471		if (exists $ID{$id}) {
472			if (! $ID{$id}{client}) {
473				my $ref = $refuse;
474				if ($ref && !established($ID{$id}{sock})) {
475					lprint("socket for ID:$id is no longer established, closing it.");
476					$ref = 0;
477				}
478				if ($ref) {
479					lprint("refusing extra vnc server for ID:$id.");
480					close $sock;
481					return;
482				} else {
483					lprint("closing and deleting previous vnc server with ID:$id.");
484					close $ID{$id}{sock};
485
486					lprint("storing new vnc server with ID:$id.");
487					$ID{$id}{client} = 0;
488					$ID{$id}{sock} = $sock;
489				}
490			} else {
491				lprint("hooking up new vnc server with existing vnc client for ID:$id.");
492				my $sock2 = $ID{$id}{sock};
493				delete $ID{$id};
494				hookup($sock, $sock2, "ID:$id");
495			}
496		} else {
497			lprint("storing new vnc server with ID:$id.");
498			$ID{$id}{client} = 0;
499			$ID{$id}{sock} = $sock;
500		}
501	} else {
502		lprint("invalid ID:NNNNN string for vnc server: $buf");
503		close $sock;
504		return;
505	}
506}
507
508sub established {
509	my $fh = shift;
510
511	return established_linux_proc($fh);
512
513	# not working:
514	my $est = 1;
515	my $str = "Z";
516	my $res;
517	#$res = recv($fh, $str, 1, MSG_PEEK | MSG_DONTWAIT);
518	if (defined($res)) {
519		lprint("established OK:  $! '$str'.");
520		$est = 1;
521	} else {
522		# would check for EAGAIN here to decide ...
523		lprint("established err: $! '$str'.");
524		$est = 1;
525	}
526	return $est;
527}
528
529
530sub established_linux_proc {
531	# hack for Linux to see if remote side has gone away:
532	my $fh = shift;
533
534	# if we can't figure things out, we must return true.
535	if ($uname !~ /Linux/) {
536		return 1;
537	}
538
539	my @proc_net_tcp = ();
540	if (-e "/proc/net/tcp") {
541		push @proc_net_tcp, "/proc/net/tcp";
542	}
543	if (-e "/proc/net/tcp6") {
544		push @proc_net_tcp, "/proc/net/tcp6";
545	}
546	if (! @proc_net_tcp) {
547		return 1;
548	}
549
550	my $n = fileno($fh);
551	if (!defined($n)) {
552		return 1;
553	}
554
555	my $proc_fd = "/proc/$$/fd/$n";
556	if (! -e $proc_fd) {
557		return 1;
558	}
559
560	my $val = readlink($proc_fd);
561	if (! defined $val || $val !~ /socket:\[(\d+)\]/) {
562		return 1;
563	}
564	my $num = $1;
565
566	my $st = '';
567
568	foreach my $tcp (@proc_net_tcp) {
569		if (! open(TCP, "<$tcp")) {
570			next;
571		}
572		while (<TCP>) {
573			next if /^\s*[A-z]/;
574			chomp;
575			#  sl  local_address rem_address   st tx_queue rx_queue tr tm->when retrnsmt   uid  timeout inode
576			# 170: 0102000A:170C FE02000A:87FA 01 00000000:00000000 00:00000000 00000000  1001        0 423294766 1 f6fa4100 21 4 4 2 -1
577			# 172: 0102000A:170C FE02000A:87FA 08 00000000:00000001 00:00000000 00000000  1001        0 423294766 1 f6fa4100 21 4 4 2 -1
578			my @items = split(' ', $_);
579			my $state = $items[3];
580			my $inode = $items[9];
581			if (!defined $state || $state !~ /^\d+$/) {
582				next;
583			}
584			if (!defined $inode || $inode !~ /^\d+$/) {
585				next;
586			}
587			if ($inode == $num) {
588				$st = $state;
589				last;
590			}
591		}
592		close TCP;
593		last if $st ne '';
594	}
595
596	if ($st ne '' && $st != 1) {
597		return 0;
598	}
599	return 1;
600}
601
602sub handler {
603	lprint("\[$$/$CURR] got SIGTERM.");
604	close $SOCK1 if $SOCK1;
605	close $SOCK2 if $SOCK2;
606	exit;
607}
608
609sub hookup {
610	my ($sock1, $sock2, $tag) = @_;
611
612	my $worker = fork();
613
614	if (! defined $worker) {
615		lprint("failed to fork worker: $!");
616		close $sock1;
617		close $sock2;
618		return;
619	} elsif ($worker) {
620		close $sock1;
621		close $sock2;
622		wait;
623	} else {
624		cleanup();
625		if (fork) {
626			exit 0;
627		}
628		setpgrp(0, 0);
629		$SOCK1 = $sock1;
630		$SOCK2 = $sock2;
631		$CURR  = $tag;
632		$SIG{TERM} = "handler";
633		$SIG{INT}  = "handler";
634		xfer_both($sock1, $sock2);
635		exit 0;
636	}
637}
638
639sub xfer {
640	my ($in, $out) = @_;
641
642	$RIN = $WIN = $EIN = "";
643	$ROUT = "";
644	vec($RIN, fileno($in), 1) = 1;
645	vec($WIN, fileno($in), 1) = 1;
646	$EIN = $RIN | $WIN;
647
648	my $buf;
649
650	while (1) {
651		my $nf = 0;
652		while (! $nf) {
653			$nf = select($ROUT=$RIN, undef, undef, undef);
654		}
655		my $len = sysread($in, $buf, 8192);
656		if (! defined($len)) {
657			next if $! =~ /^Interrupted/;
658			lprint("\[$$/$CURR] $!");
659			last;
660		} elsif ($len == 0) {
661			lprint("\[$$/$CURR] Input is EOF.");
662			last;
663		}
664		my $offset = 0;
665		my $quit = 0;
666		while ($len) {
667			my $written = syswrite($out, $buf, $len, $offset);
668			if (! defined $written) {
669				lprint("\[$$/$CURR] Output is EOF. $!");
670				$quit = 1;
671				last;
672			}
673			$len -= $written;
674			$offset += $written;
675		}
676		last if $quit;
677	}
678	close($out);
679	close($in);
680	lprint("\[$$/$CURR] finished xfer.");
681}
682
683sub xfer_both {
684	my ($sock1, $sock2) = @_;
685
686	my $parent = $$;
687
688	my $child = fork();
689
690	if (! defined $child) {
691		lprint("$prog\[$$/$CURR] failed to fork: $!");
692		return;
693	}
694
695	$SIG{TERM} = "handler";
696	$SIG{INT}  = "handler";
697
698	if ($child) {
699		lprint("[$$/$CURR] parent 1 -> 2.");
700		xfer($sock1, $sock2);
701		select(undef, undef, undef, 0.25);
702		if (kill 0, $child) {
703			select(undef, undef, undef, 0.9);
704			if (kill 0, $child) {
705				lprint("\[$$/$CURR] kill TERM child $child");
706				kill "TERM", $child;
707			} else {
708				lprint("\[$$/$CURR] child  $child gone.");
709			}
710		}
711	} else {
712		select(undef, undef, undef, 0.05);
713		lprint("[$$/$CURR] child  2 -> 1.");
714		xfer($sock2, $sock1);
715		select(undef, undef, undef, 0.25);
716		if (kill 0, $parent) {
717			select(undef, undef, undef, 0.8);
718			if (kill 0, $parent) {
719				lprint("\[$$/$CURR] kill TERM parent $parent.");
720				kill "TERM", $parent;
721			} else {
722				lprint("\[$$/$CURR] parent $parent gone.");
723			}
724		}
725	}
726}
727
728sub fsleep {
729	my ($time) = @_;
730	select(undef, undef, undef, $time) if $time;
731}
732
733sub cleanup {
734	close $client_listen  if $client_listen;
735	close $client_listen6 if $client_listen6;
736	close $server_listen  if $server_listen;
737	close $server_listen6 if $server_listen6;
738	foreach my $id (keys %ID) {
739		close $ID{$id}{sock};
740	}
741}
742