aboutsummaryrefslogtreecommitdiff
path: root/testscripts/slave-agent
blob: e3ce220f23e77e31521348c4f17c972607c31eba (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
#!/usr/bin/perl -w
#/**************************************************************************/
#/*                                                                        */
#/* Copyright (c) 2015-2016 Qindel Group (http://www.qindel.com)           */
#/*                                                                        */
#/* NXSCRIPTS, NX protocol compression and NX extensions to this software  */
#/* are copyright of NoMachine. Redistribution and use of the present      */
#/* software is allowed according to terms specified in the file LICENSE   */
#/* which comes in the source distribution.                                */
#/*                                                                        */
#/* Check http://www.nomachine.com/licensing.html for applicability.       */
#/*                                                                        */
#/* NX and NoMachine are trademarks of Medialogic S.p.A.                   */
#/*                                                                        */
#/* All rights reserved.                                                   */
#/*                                                                        */
#/**************************************************************************/

# This is a test script for the slave channel feature. While there are no
# particular requirements for the slave channel command, what makes the most
# sense is to use the feature to run some sort of multiplexer.
#
# This script contains functionality intended to test the channel's bandwidth,
# latency and integrity.
#
# Usage:
# Set NX_SLAVE_CMD to this script and enable the slave channel
#
# Run:
# nxproxy [...] slave=12000
# nxagent -display nx/nx,options=nxagent.conf # slave=22000 in nxagent.conf
# 
# Where 12000 and 22000 are example TCP ports the program will listen on.
# 
# For ease of debugging and running both sides on a single machine, the script
# reacts to its own name and changes the prompt to "Proxy" if $0 contains
# "proxy", or "Agent" if it contains "agent". This has no other effect.
#
# 

use strict;
use POSIX ":sys_wait_h";

my $me = "?";
my $EXIT;

$| = 1;

if ( $0 =~ /proxy/i ) {
	$me = "Proxy";
} elsif ( $0 =~ /agent/i ) {
	$me = "Agent";
} else {
	$me = $0;
}


print "$me slave. ";
if ( scalar @ARGV ) {
	print "Called with arguments: " . join(' ', @ARGV) . "\n\n";
} else {
	print "Called without arguments.\n\n";
}


my %commands;
register('quit'     , \&cmd_quit   , "Exit.");
register('fork'     , \&cmd_fork   , "Test forking a child process.");
register('exec'     , \&cmd_exec   , "Test calling another process via exec.");
register('system'   , \&cmd_system , "Test calling another process via system.");
register('echo'     , \&cmd_echo   , "Echo text after the command. Tests channel latency.");
register('blkecho'  , \&cmd_blkecho, "Echo data by 1k blocks. Tests channel integrity.");
register('reexec'   , \&cmd_reexec , "Reexecute slave handler.");
register('chargen'  , \&cmd_chargen, "Output characters forever. Tests channel throughput.");
register('randgen'  , \&cmd_randgen, "Output random characters forever. Tests channel throughput.");
register('discard'  , \&cmd_discard, "Accept characters forever. Tests channel throughput.");
register('fastgen'  , \&cmd_fastgen, "Output a single character forever. Tests channel throughput.");
register('env'      , \&cmd_env    , "Dump the environment.");
register('help'     , \&cmd_help   , "Shows this help.");
register('pwd'      , \&cmd_pwd    , "Print working directory.");
cmd_help();



#print "$me> ";
my $line;
while(!$EXIT) {

	print "$me> ";

	# Buffered IO screws things up
	my $c="";
	$line = "";
	while($c ne "\n") {
		my $ret = sysread(STDIN, $c, 1);
		if (!defined $ret) {
			die "Read failed: $!";
		}
	
		if (!$ret) {
			last;
		}

		$line .= $c;
	}

	chomp $line;
	$line =~ s/\r+$//;
	$line =~ s/\n+$//;

	next unless ( $line );

	my ($cmd, @args) = split(/\s+/, $line);
	if ( exists $commands{$cmd} ) {
		$commands{$cmd}->{handler}->( @args );
	} else {
		print "Unknown command: '$cmd'\n";
	}

}

print "$me slave terminated.\n";

sub register {
	my ($name, $handler, $desc) = @_;
	$commands{$name} = { handler => $handler, desc => $desc };
}


sub cmd_quit {
	$EXIT = 1;
}

sub cmd_echo {
	my (@args) = @_;
	print "You said: '" . join(' ', @args) . "'\n\n";
}

sub cmd_blkecho {
	my $size = shift // 1024;
	unless ($size =~ /^\d+/ ) {
		print "The argument must be a number\n\n";
		return;
	}

	my $buf;
	while(1) {
		my ($tmp, $ret);
		$buf = "";

		while(length($buf) < $size) {
			$ret = sysread(STDIN, $tmp, $size - length($buf));
			if ( !defined $ret ) {
				die "Error reading from socket: $!";
			}
			
			last if ( $ret == 0 );
			$buf .= $tmp;
		}

		my $written =0;
		while($written < $size) {
			my $ret = syswrite(STDOUT, $buf, $size, $written);
			if (!defined $ret) {
				die "Error writing to socket: $!";
			}

			last if ( $ret == 0);
			$written += $ret;
		}
	}
}

sub cmd_reexec {
	print "Will now re-execute: $0 " . join(' ', @ARGV) . "\n";
	exec($0, @ARGV);
}

sub cmd_exec {
	print "Will now exec: uname -a\n";
	exec("uname", "-a");
}

sub cmd_system {
	print "Will now call: uptime\n";
	system("uptime");
	print "\n";
}

# Forks off a short lived process

sub cmd_fork {
	my $pid = fork();
	if ( $pid == 0 ) {
		print "I am the child, with pid $$. Waiting 10 seconds.\n";
		sleep(10);
		print "Child exiting with code 123\n";
		exit(123);
	} else {
		print "I am the parent, my child is $pid\n";
		my $dead = waitpid($pid, 0);
		print "Reaped child $pid, return $dead\n";
	}

	print "\n";
}

sub cmd_help {
	print "Commands:\n";
	for my $cmd ( sort keys %commands ) {
		print "\t$cmd" . ( " " x (10 - length($cmd))) . ": " . $commands{$cmd}->{desc} . "\n";
	}
	print "\n";
}

# Output a single character really fast.
# Used to test bandwidth and integrity
sub cmd_fastgen {
	my $char = chr(shift // ord("x"));
	my $buf = ($char x 72) . "\n";
	while( syswrite(STDOUT, $buf) ) {
		1;
	}
}

# Output RFC 864 chargen. 
# Used to test bandwidth
sub cmd_chargen {
	my $text = "";

	for(my $i=33;$i<33+95;$i++) {
		$text .= chr($i);
	}


	my $pos = 0;
	my $strlen = 72;
	while( 1 ) {
		my $out = substr($text, $pos, $strlen);

		if ( $pos + $strlen > length($text) ) {
		     $out .= substr($text, 0, $pos + $strlen - length($text) + 1);
		}

		$out .= "\n";

		syswrite(STDOUT, $out) or return;

		if ( ++$pos >= length($text) ) {
		     $pos=0;
		}
	}

}

# Output random data
# Used to test channel integrity and bandwidth with incompressible content.
# Typically slower than chargen/fastgen.

sub cmd_randgen {
	if ( open(my $fh, '<', '/dev/urandom') ) {
		my $buf;
		while(1) {
			sysread($fh, $buf, 1024);
			syswrite(STDOUT, $buf) or return;
		}
	} else {
		print "Failed to open /dev/urandom: $!. May not be available on this architecture.\n\n";
	}
}

# Accept arbitrary data
# Used to test bandwidth

sub cmd_discard {
	my $buf = "";

	while( sysread(STDIN, $buf, 1024) ) {
		1;
	}

}

# Dump the environment

sub cmd_env {
	my $longest = 0;

	foreach my $var (keys %ENV) {
		if ( $longest < length($var) ) {
			$longest = length($var);
		}
	}

	foreach my $var (sort keys %ENV) {
		print "$var" . (" " x ($longest - length($var))) . ": $ENV{$var}\n";
	}

	print "\n";
}

# Show the current directory

sub cmd_pwd {
	require Cwd;
	import Cwd;
	print "Current directory: " . getcwd() . "\n\n";
}