1 #!/usr/bin/perl -w
3 # $Id$
5 # $Log$
6 # Revision 1.1 2002/11/29 12:02:00 stanleyhopcroft
7 # New plugin to check the ICA browse service (used by Citrix Metaframe servers) from
8 # Ed Rolison and Tom De Blende.
9 #
11 # Ed Rolison 15/06/02
12 # ed@nightstalker.net
13 # If it doesn't work, please let me know, I've only had access to my
14 # environment so I'm not 100% sure.
15 #
16 # If you want to mess around with this script, then please feel free
17 # to do so.
18 # However, if you add anything 'funky' then I'd really appreciate
19 # hearing about it.
20 #
21 # Oh, and if you do ever make huge amounts of money out of it, cut me
22 # in :)
24 use strict ;
26 use IO::Socket;
27 use IO::Select;
28 use FileHandle;
29 use Getopt::Long ;
31 use vars qw($opt_H $opt_B $opt_W $opt_T $debug @citrix_servers $crit_pub_apps $warn_pub_apps $long_list);
32 use utils qw(%ERRORS &print_revision &support &usage);
34 my $PROGNAME = 'check_citrix' ;
36 sub print_help ();
37 sub print_usage ();
38 sub help ();
39 sub version ();
41 delete @ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
43 # You might have to change this...
45 use constant PACKET_TIMEOUT => 1;
46 # Number of seconds to wait for further UDP packets
47 use constant TEST_COUNT => 2;
48 # Number of datagrams sent without reply
49 use constant BUFFER_SIZE => 1500;
50 # buffer size used for 'recv' calls.
51 use constant LONG_LIST => 0 ;
52 # this is for if you have many published applications.
53 # if you set it, it won't do any harm, but may slow the test
54 # down a little. (Since it does a 'recv' twice instead of
55 # once and therefore may have to wait for a timeout).
56 use constant ICA_PORT => 1604;
57 # what port ICA runs on. Unlikely to change.
59 # End user config.
61 Getopt::Long::Configure('bundling', 'no_ignore_case');
62 GetOptions
63 ("V|version" => \&version,
64 "h|help" => \&help,
65 "d|debug" => \$debug,
66 "B|broadcast_addr:s" => \$opt_B,
67 "C|citrix_servers:s" => \@citrix_servers,
68 "L|long_list" => \$long_list,
69 "P|crit_pub_apps:s" => \$crit_pub_apps,
70 "T|Packet_timeout:i" => \$opt_T,
71 "W|warn_pub_apps:s" => \$warn_pub_apps,
72 ) ;
74 # configuration section
76 my $broadcast_addr = $1 if $opt_B and $opt_B =~ m#(\d+\.\d+\.\d+\.\d+)# ;
77 usage("Invalid broadcast address: $opt_B\n") if $opt_B and not defined($broadcast_addr) ;
79 usage("You must provide either the names of citrix servers or the broadcast address of the subnet containing them\n")
80 unless (@citrix_servers or $broadcast_addr) ;
82 my @target = defined $broadcast_addr ? ($broadcast_addr) : @citrix_servers ;
84 usage("You must provide the names of the published applications that the Citrix browser should be advertising\n")
85 unless $crit_pub_apps or $warn_pub_apps ;
87 my $Timeout = $opt_T if defined $opt_T ;
88 $Timeout = PACKET_TIMEOUT unless defined $Timeout ;
89 $long_list = LONG_LIST unless defined $long_list ;
91 my @crit_pub_apps = $crit_pub_apps ? split(/,/, $crit_pub_apps) : () ;
92 my @warn_pub_apps = $warn_pub_apps ? split(/,/, $warn_pub_apps) : () ;
94 # definitions of query strings. Change at your own risk :)
95 # this info was gathered with tcpdump whilst trying to use an ICA client,
96 # so I'm not 100% sure of what each value is.
98 my @bcast_helo = &tethereal2list(<<'End_of_Tethereal_trace', '1e') ;
99 0020 ff ff 04 d6 06 44 00 26 4a 76 1e 00 01 30 02 fd .....D.&Jv...0..
100 0030 a8 e3 00 02 f5 95 9f f5 30 07 00 00 00 00 00 00 ........0.......
101 0040 00 00 00 00 00 00 01 00
102 End_of_Tethereal_trace
104 my @bcast_query_app = &tethereal2list(<<'End_of_Tethereal_trace', '24') ;
105 0020 64 17 04 50 06 44 00 2c 85 6a 24 00 01 32 02 fd d..P.D.,.j$..2..
106 0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
107 0040 00 00 00 00 00 00 21 00 02 00 00 00 00 00 ......!......
108 End_of_Tethereal_trace
110 my @direct_helo = &tethereal2list(<<'End_of_Tethereal_trace', '20') ;
111 0020 64 17 05 0f 06 44 00 28 ab b5 20 00 01 30 02 fd d....D.(.. ..0..
112 0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
113 0040 00 00 00 00 00 00 00 00 00 00
114 End_of_Tethereal_trace
116 my @direct_query_app = &tethereal2list(<<'End_of_Tethereal_trace', '2c') ;
117 0020 64 17 05 10 06 44 00 34 7a 9a 2c 00 02 32 02 fd d....D.4z.,..2..
118 0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
119 0040 00 00 00 00 00 00 21 00 02 00 01 00 00 00 00 00 ......!.........
120 0050 00 00 00 00 00 00
121 End_of_Tethereal_trace
123 my $Udp = IO::Socket::INET->new( Proto => 'udp' ) || die "Socket failure: $!";
125 # select is here to allow us to set timeouts on the connections. Otherwise they
126 # just 'stop' until a server appears.
128 my $select = IO::Select->new($Udp) || die "Select failure: $!";
130 # helo needs to be broadcast, but query does not.
132 $Udp->sockopt(SO_BROADCAST, 1 );
133 $Udp->autoflush(1);
135 my ($remote_host, $buff, $buff2, $raddr, $rport, $rhost, @remote_response);
136 my (@query_message, $send_addr, $this_test) ;
138 $buff = $buff2 = '';
139 $this_test = 0;
141 # If there is no response to the first helo packet it will be resent
142 # up to TEST_COUNT (see at the top).
144 while ( ++$this_test <= TEST_COUNT && !$buff ) {
146 print "Sending helo datagram. datagram number: ", $this_test, "\n" if $debug ;
148 # if we have multiple targets, we probe each of them until we get a
149 # response...
151 foreach my $destination (@target) {
152 @query_message = ( $broadcast_addr ? @bcast_helo : @direct_helo) ;
153 print "Querying $destination for master browser\n" if $debug ;
154 $send_addr = sockaddr_in(ICA_PORT, inet_aton($destination) );
155 &dump(pack('C*', @query_message)) if $debug ;
156 $Udp->send( pack('C*', @query_message), 0, $send_addr );
157 if ( $select->can_read($Timeout) ) {
158 $remote_host = $Udp->recv($buff, BUFFER_SIZE, 0 );
159 }
161 last if $buff ;
162 sleep 1 ;
164 } # foreach destination
165 } # while loop
167 # ok we've looped several times, looking for a response. If we don't have one
168 # yet, we simply mark the whole lot as being unavailable.
170 unless ( $buff ) {
171 print "Failed. No response to helo datagram (master browser query) from ", $broadcast_addr ? $broadcast_addr : "@citrix_servers", ".\n" ;
172 exit $ERRORS{CRITICAL} ;
173 }
175 ($rport, $raddr) = sockaddr_in( $remote_host );
176 $rhost = gethostbyaddr( $raddr, AF_INET );
177 my @tmpbuf = unpack('C*', $buff );
178 if ( $debug ) {
179 print "$rhost:$rport responded with: ",length($buff), " bytes\n";
180 &dump($buff) ;
181 } #if debug
183 # now we have a response, then we need to figure out the master browser, and
184 # query it for published applications...
186 my $master_browser = join '.', @tmpbuf[32..35] ;
188 # ok should probably error check this, because it's remotely possible
189 # that a server response might be completely wrong...
191 print "Master browser = $master_browser\n" if $debug ;
193 $send_addr = sockaddr_in(ICA_PORT, inet_aton($master_browser));
195 if ( $broadcast_addr ) {
196 print "using broadcast query\n" if $debug ;
197 @query_message = @bcast_query_app;
198 } else {
199 print "using directed query\n" if $debug ;
200 @query_message = @direct_query_app;
201 }
203 # now we send the appropriate query string, to the master browser we've found.
205 $buff = '';
206 $this_test = 0 ;
208 print "Querying master browser for published application list\n" if $debug ;
210 while ( ++$this_test <= TEST_COUNT && !$buff ) {
211 print "Sending application query datagram. datagram number: ", $this_test, "\n" if $debug ;
212 &dump(pack('C*', @query_message)) if $debug ;
213 $Udp->send( pack ('C*', @query_message), 0, $send_addr );
215 if ( $select->can_read($Timeout) ) {
216 $remote_host = $Udp->recv($buff, BUFFER_SIZE, 0 );
217 # $buff = substr($buff, 32) ;
218 # Hope that ICA preamble is first 32 bytes
219 }
221 # long application lists are delivered in multiple packets
223 my $buff2 = '' ;
224 while ( $long_list && $select->can_read($Timeout) ) {
225 $remote_host = $Udp->recv($buff2, BUFFER_SIZE, 0 );
226 $buff .= $buff2 if $buff2 ;
227 # $buff .= substr($buff2, 32) if $buff2 ;
228 # Hope that ICA preamble is first 32 bytes
229 }
231 last if $buff ;
232 sleep 1 ;
234 } # while test_count
236 unless ( $buff ) {
237 print "Failed. No response to application query datagram from ", $master_browser, ".\n" ;
238 exit $ERRORS{CRITICAL} ;
239 }
241 # we got a response from a couple of retries of the app query
243 ($rport, $raddr) = sockaddr_in ( $remote_host );
244 $rhost = gethostbyaddr ( $raddr, AF_INET );
245 if ( $debug ) {
246 print "$rhost:$rport responded to app query with: ",length($buff), " bytes\n";
247 &dump($buff) ;
248 } #debug
250 my $app_list = $buff ;
251 # delete nulls in unicode
252 # but only if there is unicode (usually from
253 # broadcast query)
255 $app_list =~ s/(?:(\w| |-)\x00)/$1/g
256 if $app_list =~ /(?:(?:(?:\w| |-)\x00){3,})/ ;
257 # FIXME an application name is
258 # 3 or more unicoded characters
260 # FIXME locale
261 # extract null terminated strings
263 my (@clean_app_list, $clean_app_list) ;
264 $clean_app_list = join(',', @clean_app_list = $app_list =~ m#([A-Za-z](?:\w| |-|[ÄÖÜäöüß])+?(?=\x00))#g ) ;
266 # patch for German umlauts et al from Herr Mike Gerber.
268 # $clean_app_list = join(',', @clean_app_list = $app_list =~ m#([A-Z](?:\w| |-)+?(?=\x00))#g ) ;
270 # FIXME everyones apps don't start with caps
272 print qq(Received list of applications: "$clean_app_list".\n) if $debug ;
274 if ( scalar @crit_pub_apps and my @missing = &simple_diff(\@clean_app_list, \@crit_pub_apps) ) {
275 print qq(Failed. "@missing" not found in list of published applications),
276 qq( "$clean_app_list" from master browser "$master_browser".\n) ;
277 exit $ERRORS{CRITICAL} ;
278 }
280 if ( my @missing = &simple_diff(\@clean_app_list, \@warn_pub_apps) ) {
281 print qq(Warning. "@missing" not found in list of published applications),
282 qq( "$clean_app_list" from master browser "$master_browser".\n) ;
283 exit $ERRORS{WARNING} ;
284 }
286 my @x = (@crit_pub_apps, @warn_pub_apps) ;
287 my $blah = ( scalar(@x) == 1 ? 'the published application "' . join(',', @x) . '" is available' :
288 'the published applications "' . join(',', @x) . '" are available' ) ;
290 print qq(Ok. Citrix master browser "$master_browser" reported that $blah.\n) ;
291 exit $ERRORS{OK} ;
293 # sleep $Timeout;
294 # because otherwise we can get responses from
295 # the WRONG servers. DOH
296 close $Udp;
299 sub print_usage () {
300 print "Usage: $PROGNAME (-B <broadcast_address>| -C <citrix_server>..) -W <pub_app1,pub_app2..> -P <pub_app1,pub_app2,>\n";
301 }
303 sub print_help () {
304 print_revision($PROGNAME,'$Revision$ ');
305 print "Copyright (c) 2002 Ed Rolison/Tom De Blende/Karl DeBisschop/S Hopcroft
307 Perl Check Citrix plugin for NetSaint.
309 Returns OK if the Citrix master browser returns a 'published application' list that contain names specified by the -W or -P options
311 The plugin works by
312 If the -B option is specified, sending a broadcast helo to find the address of the Citrix master browser in the specified subnet.
313 return critical if there is no reply;
314 Else if the -C option is specified
315 send a direct helo to the specified server until there is a response (containing the address of the Citrix master browser)
317 Query the master browser (using a 'broadcast published applications query ' if -B) and compare the published applications returned
318 to those specified by -W and -P options
320 return Critical if the published applications specified by -P is not a subset of the query responses;
321 return Warning if the published applications specified by -W is not a subset of the query responses;
322 return OK
324 ";
325 print_usage();
326 print '
327 -B, --broadcast_address=STRING
328 The broadcast address that should contain Citrix master browser. This option takes precedence over -C.
329 -C, --citrix_server:STRING
330 Optional __name(s)__ of Citrix servers that could be the master browser (used when broadcast not possible).
331 -L, --long_list
332 Set this if you have heaps of published applications (ie more than will fit in _one_ UDP packet)
333 -P, --crit_published_app=STRING
334 Optional comma separated list of published application that must be in the response from the master browser.
335 Check returns critical otherwise.
336 -T, --packet-timeout:INTEGER
337 Time to wait for UDP packets (default 1 sec).
338 -W, --warn_published_app=STRING
339 Optional comma separated list of published application that should be in the response from the master browser.
340 Check returns warning otherwise.
341 -d, --debug
342 Debugging output.
343 -h, --help
344 This stuff.
346 ';
347 support();
348 }
350 sub version () {
351 print_revision($PROGNAME,'$Revision$ ');
352 exit $ERRORS{'OK'};
353 }
355 sub help () {
356 print_help();
357 exit $ERRORS{'OK'};
358 }
360 sub dump {
361 my ($x) = shift @_ ;
362 my (@x, @y, $y, $i, $rowcount) ;
363 my ($nr, $j, $number_in_row, $number_of_bytes) ;
364 my $dump ;
366 $number_in_row = 16 ;
367 $number_of_bytes = length $x ;
368 $nr = 0 ;
370 # styled on tethereal.
372 foreach $j (1 .. int( $number_of_bytes / $number_in_row) ) {
373 $y = substr($x, ($j - 1)*$number_in_row, $number_in_row) ;
374 @y = unpack("C*", $y) ;
375 $y =~ tr /\x00-\x19/./ ;
376 $rowcount = sprintf("%4.4x", ($j - 1) * 0x10 ) ;
377 $dump .= sprintf "%s %s %s\n", $rowcount, join(" ", map { sprintf "%2.2x", $_} @y), $y ;
378 $nr++ ;
379 }
381 if ( $number_of_bytes % $number_in_row > 0 ) {
382 my $spaces_to_text = $number_in_row * 3 - 1 + 3 ;
383 $rowcount = sprintf("%4.4x", $nr * 0x10 ) ;
384 $y = substr($x, $nr * $number_in_row ) ;
385 @y = unpack("C*", $y) ;
386 my $bytes = join(" ", map { sprintf "%2.2x", $_} @y) ;
387 my $spaces = ' ' x ($spaces_to_text - length($bytes)) ;
388 $dump .= sprintf "%s %s%s%s\n", $rowcount, $bytes, $spaces, $y ;
389 }
391 print $dump, "\n" ;
393 }
395 sub tethereal2list {
396 my ($tethereal_dump, $start_byte) = @_ ;
398 # return an array containing qw(0xef 0xab 0x00 ...) from a tethereal trace.
399 # skip all stuff until the first byte given by $start_byte.
401 return undef unless $tethereal_dump =~ /\d\d\d\d \S\S(?: \S\S){1,15}/ ;
403 my $hex_start_byte = hex($start_byte) ;
404 my @x = $tethereal_dump =~ m#(.+)#g ;
405 my @y = map unpack("x6 a47", $_), @x ;
406 my @z = map { my $y = $_; $y =~ s/(\S\S)/hex($1)/eg; my @a = split(' ', $y); @a } @y ;
407 shift @z, while $z[0] ne $hex_start_byte ;
409 @z ;
411 }
413 sub simple_diff {
415 my ( $a_list, $b_list) = @_ ;
417 # simple set difference 'Recipe 4.7 Perl Cookbook', Christiansen and Torkington
419 my (%seen, @missing) ;
421 @seen{@$a_list} = () ;
423 foreach my $item (@$b_list) {
424 push @missing, $item unless exists $seen{$item} ;
425 }
427 @missing ;
428 }