#!/usr/bin/perl -w

# Ed Rolison 15/06/02
# ed@nightstalker.net
# If it doesn't work, please let me know, I've only had access to my e
+nvironment
# so I'm not 100% sure.
#
# No liability accepted for problems, mistakes, inaccuracies or nuclea
+r war.
#
# If you want to mess around with this script, then please feel free t
+o do so.
# however, if you add anything 'funky' then I'd really appreciate hear
+ing about it.
#
# Oh, and if you do ever make huge amounts of money out of it, cut me 
+in :)
# version 1.4.something.

use IO::Socket::INET;
use IO::Select;
use FileHandle;
use strict;

#configuration section

my $debug = 0;
my $timeout = 2;
my $test_count = 2;
my $date = `$ENV{'DATE'}`;
my $buffer_size = 1500; # buffer size used for 'recv' calls.

#a word of warning - at the moment these test _will_ match substrings
#of the applications. So if you have something like 'Desktop' and 'Des
+ktopFull'
#Desktop will match on either. I'll probably fix this in a later versi
+on.

#a 'single' target will be assumed to be a broadcast address for a clu
+ster.
#that's probably not right, but I've got a local subnet cluster, and
#a remote cluster that I can't broadcast to. So this works well enough
+.
#feel free to hack in support for discriminating between broadcast/sta
+ndalone though....
 

my (%tests) = 
(
  'citrix' =>  #this is the name of the 'machine that this test appear
+s to 
               #be from in the bb display
  {
    testname => 'icaclstr',       #hopefully fairly obvious - which co
+lumn in BB
    target => [ "10.0.127.255" ],  
                               #either a list of servers, or a broadca
+st address
    red_published_apps =>           # apps which trigger a 'red' when 
+down
      [ "Desktop","Meta" ],
    yellow_published_apps =>        #apps which trigger a 'yellow' whe
+n down.
      [ "Desktop_2000", "RSC", "GSI", "IExplorer" ],
 
    longlist => 0, # this is for if you have many published applicatio
+ns.
                   # if you set it, it won't do any harm, but may slow
+ the test
           # down a little. (Since it does a 'recv' twice instead of 
                   # once and therefore may have to wait for a timeout
+).
  },
  'lincoln' =>
  { 
    testname => 'icaclstr',
    target => 
      [ "tsl055","tsl07","tsl08","tsl09","tsl10",
        "tsl11","tsl12","tsl13","tsl14" ],
    red_published_apps => 
      [ "Asap","Archive",
        "UserManager","Visio2000","WTS" ],
    yellow_published_apps => [ "WAdmin", "Application Launcher" ],
    longlist => 1
  }, 
);

#End user config.

#ica port number. 
my $ica_port = 1604;             #what port ICA runs on. Unlikely to c
+hange.

#definitions of query strings. Change at your own risk :)
#this info was gathered with tcpdump whilst trying to use an ICA clien
+t,
#so I'm not 100% sure of what each value is.
my $app_response_offset = 0x28;
my @bcast_helo = 
  ( 0x1e,0x00,0x01,0x30,0x02,0xfd,0xa8,0xe3,0x00,0x02,0xf5,0x95,
0x9f,0xf5,0x30,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
+0x00,0x00,0x01,0x00,0x00 );
my @bcast_query_app = 
  ( 0x24,0x00,0x01,0x32,0x02,0xfd,0xa8,0xe3,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x21,0x00,0x02,0x00,0x00,0x00,0x00,0x00, 0x00 );

my @direct_helo = 
  ( 0x20,0x00,0x01,0x30,0x02,0xfd,0xa8,0xe3,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
+0x00,0x00,0x00,0x00,0x00,0x00,0x00 );

my @direct_query_app = ( 0x2c,0x00,0x02,0x32,0x02,0xfd,0xa8,0xe3,0x00,
+0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x21,0x00,0x02,0x00,0x01,0x00,0x00,0x00,0x00,0x00,
+0x00,0x00,0x00,0x00,0x00,0x00,0x00 );

if ( $debug == 1 )
{
  print "*** Running in test mode\n";
}

#we open 2 UDP ports - one to send the 'search' and the other to query
+ the app list.
my $UDP_HELO = IO::Socket::INET -> new ( Proto => "udp" ) || die "Sock
+et failure: $!";
my $UDP_QUERY = IO::Socket::INET -> new ( Proto => "udp" ) || die "Soc
+ket failure: $!";

#select is here to allow us to set timeouts on the connections. Otherw
+ise they 
#just 'stop' until a server appears.
my $select_helo = IO::Select -> new ($UDP_HELO) || die "Select failure
+: $!";
my $select_query = IO::Select -> new ($UDP_QUERY) || die "Select failu
+re: $!";
my $send_addr ;

#helo needs to be broadcast, but query does not.
$UDP_HELO -> sockopt(SO_BROADCAST, 1 );
#autoflush both.
$UDP_HELO -> autoflush(1);
$UDP_QUERY -> autoflush(1);

my ( $color, $line2, $remote_host, $buff, $buff2, $raddr, $rport, $rho
+st, 
     @remote_response, $master_browser );
#right, run through the %tests hash above, and test each of the machin
+es listed.
foreach my $test_target ( keys ( %tests ) )
{
  $color = "clear";
  $line2 = "";
  if ( $debug ) { print "testing $test_target\n" };
  $buff = "";
  $buff2 = "";
  my $this_test = 0;
  #If the first test fails, (as it sometimes does, UDP being unreliabl
+e)
  #then it'll retry up to $test_count times (see at the top).
  while ( $this_test <= $test_count && !$buff ) 
  {
    if ( $debug ) { print "Running test: ", ++$this_test,"\n" };
    #if we have multiple targets, we probe each of them until we get a
+ 
    #response...
    foreach my $destination ( @ { $tests{$test_target}{target} } ) 
    {
      my @query_message = @bcast_helo;
      #if we haven't got a response yet, try this one.
      if ( !$buff ) 
      {
        if ( $debug ) { print "Querying $destination for master browse
+r\n"; }
        $send_addr = sockaddr_in("$ica_port", inet_aton("$destination"
+) );
        if ( $#{ $tests{$test_target}{target} } > 1)
        {
          @query_message = @direct_helo;
        }
        $UDP_HELO -> send ( pack ("C"x $#query_message, @query_message
+), 0, $send_addr ); 
        if ( $select_helo -> can_read($timeout) )
        {
          $remote_host = $UDP_HELO -> recv($buff, $buffer_size, 0 );
        }
      } # if (!$buff)
    } #foreach destination
  } # if test count loop
  #ok we've looped several times, looking for a response. If we don't 
+have one 
  #yet, we simply mark the whole lot as being unavailable.
  if ( $buff )
  {
    ($rport, $raddr) = sockaddr_in ( $remote_host );
    $rhost = gethostbyaddr ( $raddr, AF_INET );
    my @tmpbuf = unpack ("C" x length($buff), $buff );
    if ( $debug )
    {
      print "$rhost:$rport responded with: ",length($buff), " bytes\n"
+;
      foreach (@tmpbuf)
      {
        printf ("%02X ", $_ );
      }
      print "\n";
    } #if debug

    #now we have a response, then we need to figure out the master bro
+wser, and 
    #query it for published applications...

    $master_browser = "$tmpbuf[32].$tmpbuf[33].$tmpbuf[34].$tmpbuf[35]
+";
     
    #ok should probably error check this, because it's remotely possib
+le
    #that a server response might be completely wrong...
      
    $color="green";
    if ( $debug ) { print "Master browser = $master_browser\n" } ;

    $send_addr = sockaddr_in($ica_port, inet_aton("$master_browser") )
+;
    my @query_message;
    if ( $#{ $tests{$test_target}{target} } > 1)
    {
       if ( $debug ) { print "using directed query\n" };
       @query_message = @direct_query_app;
     }
     else
     {
       if ( $debug ) { print "using broadcast query\n" };
       @query_message = @bcast_query_app;
     }
   
    #now we send the appropriate query string, to the master browser w
+e've found.
    $buff = "";
    while ( $this_test <= $test_count && !$buff ) 
    {
      $UDP_QUERY -> send ( pack ("C"x $#query_message, @query_message)
+, 0, $send_addr ); 
      if ( $select_query -> can_read($timeout) )
      {
        $remote_host = $UDP_QUERY -> recv($buff, $buffer_size, 0 );
      }
      #this is icky, because i _most_ situations, there isn't going to
+ be
      #any more data... but we have a server with a LONG published app
+s list
      #which takes two packets to deliver. Good eh?
      if ( $tests{$test_target}{longlist} && $select_query -> can_read
+($timeout) )
      {
    $UDP_QUERY -> recv($buff2, $buffer_size, 0 );
        if ( $buff2 )
          {
             $buff = join ("", $buff, $buff2);
          }
      }
    } #while test_count
    if ($buff)  #eg if we got a response from a couple of retries of t
+he app query
    {
      ($rport, $raddr) = sockaddr_in ( $remote_host );
      $rhost = gethostbyaddr ( $raddr, AF_INET );
      @tmpbuf = unpack ("C" x length($buff), $buff );
      if ( $debug )
      {
        print "$rhost:$rport responded to app query with: ",length($bu
+ff), " bytes\n";
        foreach (@tmpbuf)
        {
          printf ("%02X ",$_ );
        }
        print "\n";
      } #debug

      #now we strip out the icky null chars. This is what makes the pa
+ttern
      #matching on the app list less selective. The problem is that so
+me
      #serves return an app list in ASCII, and others return it in uni
+code...
      #stripping the nulls is the easiest way of converting it to a co
+mmon format.
      my @newbuf;
      foreach my $value (@tmpbuf)
      {
        if ( $value > 31 )
        { 
          push(@newbuf, $value);
        }
      }
      #now after trashing the nulls, we need to append one as a string
+ terminator.
      push(@newbuf, 0 );
      @tmpbuf=@newbuf;

      my $app_list = join("", pack("C" x $#tmpbuf, @tmpbuf ) );
      if ( $debug ) { print "Recieved list of applications: $app_list\
+n" };
 
      $line2 = "";
      #yellow first, so a red overrides it...
      foreach my $app (@{$tests{$test_target}{yellow_published_apps}} 
+)
      {
        my $app_test = $app_list;
        if ( $app_test =~ /$app/ )
        {
          $line2 = join ( "", $line2, "         $app is available.\n" 
+);  
        }
        else
        {
          $line2 = join ( "", $line2, "WARNING: $app is unavailable.\n
+" );
          $color = "yellow";
        }
      } #foreach
      foreach my $app (@{$tests{$test_target}{red_published_apps}} )
      {
        my $app_test = $app_list;
        if ( $app_test =~ /$app/ )
        {
          $line2 = join ( "", "         $app is available.\n", $line2 
+);
        }
        else
        {
          $line2 = join ( "", "WARNING: $app is unavailable.\n", $line
+2 );
          $color = "red";
        }
      } #foreach
      sleep $timeout; #because otherwise we can get responses from the
+ WRONG servers. DOH
    } # if ( !$buff)
    else
    {
      $color = "red";
      $line2 = "WARNING: No response from master browser."
    }
    
  } #if !$buff - so we skip this chunk if there was no response from a
+ny of our master browsers, since
   #there's not point trying to get an app list...   
  else
  {
    $color = "red";
    $line2 = "WARNING: NO response recieved to discovery messages.\n";
  }   
  my $line ="status $test_target.$tests{$test_target}{testname} $color
+ $date\n";
  $line = join ("", $line, "Response from master browser: $master_brow
+ser\n\n",
                    "Citrix Published Applications:\n", $line2 );
  if ( $debug )
  {
    print "$line";
  }
  else
  {
    `$ENV{'BB'} $ENV{'BBDISP'} \"$line\"`;
  }
} #foreach
close $UDP_QUERY;
close $UDP_HELO;
[download]