dlife_client.pl.in

   1 #!/usr/bin/perl -w -T
   2 # -*- perl -*-
   3 # @configure_input@
   4
   5 use strict;
   6
   7 use Getopt::Long;
   8 use LWP::UserAgent;
   9 use Socket;
  10 use IO::Socket;
  11 use Sys::Hostname;
  12 use Sys::Syslog qw(:DEFAULT setlogsock);
  13
  14 my $help;
  15 my $verbose;
  16 my $config_filename = "@CONFDIR@/client.conf";
  17 my $spooldir = "@SPOOLDIR@";
  18 my $client_version = "@VERSION@";
  19
  20 GetOptions ("help|?" => \$help,
  21             "verbose" => \$verbose,
  22             "config=s" => \$config_filename,
  23             "spooldir=s" => \$spooldir);
  24
  25 if ($help)
  26   {
  27     print STDERR <<EOF;
  28 dlife_client.pl [--help] [--verbose] \
  29                 [--spooldir=spooldir] [--config=config_file]
  30
  31 Options:
  32   --help               Displays this help text.
  33   --verbose            Lots of messages.
  34   --spooldir=spooldir  Set spool directory (default is @SPOOLDIR@).
  35   --config=config_file Use named configuration file (default is to use
  36                        @CONFDIR@/client.conf).
  37 EOF
  38   exit 1;
  39   }
  40
  41 # Open a connection to syslog.
  42 setlogsock ("unix");
  43 openlog ("dlife_client", "", "user");
  44
  45 syslog ("info", "version $client_version starting [conf=$config_filename, spool=$spooldir]");
  46
  47 # Default configuration values.
  48 my $server_url;
  49 my @server_zones = ();
  50 my @servers = ();
  51 my $max_cells_upload_per_pass = 6;
  52 my $max_cells_download_per_pass = 4;
  53
  54 # Read configuration file.
  55 open CONFIG, "<$config_filename" or die "$config_filename: $!";
  56
  57 while (<CONFIG>)
  58   {
  59     s/[\n\r]*$//;
  60     next if /^\s*\#/;
  61     next if /^\s*$/;
  62
  63     if (/^\s*server_url\s+(\S+)\s*$/)
  64       {
  65         $server_url = $1;
  66         print "server_url=$server_url\n" if $verbose;
  67       }
  68     elsif (/^\s*server_zone\s+(.*)\s*$/)
  69       {
  70         @server_zones = split /\s+/, $1;
  71         print "server_zones=", join (" ", @server_zones), "\n" if $verbose;
  72       }
  73     elsif (/^\s*server\s+(.*)\s*$/)
  74       {
  75         @servers = split /\s+/, $1;
  76         print "servers=", join (" ", @servers), "\n" if $verbose;
  77       }
  78     elsif (/^\s*max_cells_upload_per_pass\s+([1-9][0-9]*)\s*$/)
  79       {
  80         $max_cells_upload_per_pass = $1;
  81       }
  82     elsif (/^\s*max_cells_download_per_pass\s+([1-9][0-9]*)\s*$/)
  83       {
  84         $max_cells_download_per_pass = $1;
  85       }
  86     else
  87       {
  88         die "unknown configuration option: $_";
  89       }
  90   }
  91
  92 close CONFIG;
  93
  94 # Load @server_zones into a hash for rapid searching.
  95 my %server_zones;
  96 foreach (@server_zones) { $server_zones{$_} = 1; }
  97
  98 # Server URL set or @servers not empty?
  99 unless ($server_url || @servers)
 100   {
 101     die "neither server_url and servers was set: cannot do anything";
 102   }
 103
 104 # Go to spool directory.
 105 chdir $spooldir or die "$spooldir: $!";
 106
 107 # Find the list of cells to upload and arrange into a random order.
 108 my @all_upload_cells = randomize_list (glob_outgoing ());
 109
 110 unless (@all_upload_cells)
 111   {
 112     syslog ("info", "no cells to upload (is the dlife_soup process running?)");
 113     exit;
 114   }
 115
 116 # Only upload the first few cells.
 117 my @upload_cells = @all_upload_cells;
 118 splice @upload_cells, $max_cells_upload_per_pass;
 119
 120 # If server URL set, then go and download the webpage. Load appropriate
 121 # server names into @servers.
 122 if ($server_url)
 123   {
 124     syslog ("info", "contacting $server_url");
 125     print "Contacting $server_url\n" if $verbose;
 126
 127     my $ua = LWP::UserAgent->new;
 128     my $req = HTTP::Request->new ("GET", $server_url);
 129     my $rep = $ua->request ($req);
 130
 131     if ($rep->is_success)
 132       {
 133         print "Fetched page. Parsing page ...\n" if $verbose;
 134
 135         # Parse the page.
 136         my @lines = split /[\n\r]+/, $rep->content;
 137
 138         foreach (@lines)
 139           {
 140             if (/^\s*server\s+(\S*)\s+(.*)\s*$/)
 141               {
 142                 my $server = $1;
 143                 my @zones = split /\s+/, $2;
 144
 145                 # Is this server in one of our zones?
 146                 if (@server_zones)
 147                   {
 148                     foreach (@zones)
 149                       {
 150                         if (exists $server_zones{$_})
 151                           {
 152                             push @servers, $server;
 153                             last;
 154                           }
 155                       }
 156                   }
 157                 else
 158                   {
 159                     push @servers, $server;
 160                   }
 161               }
 162           }
 163
 164         print "Finished parsing page. \@servers = ",
 165           join (" ", @servers), "\n"
 166           if $verbose;
 167       }
 168     else
 169       {
 170         syslog ("error", "could not contact $server_url");
 171         print "Could not contact server.\n" if $verbose;
 172       }
 173   }
 174
 175 # Sort the server list into a random order.
 176 @servers = randomize_list (@servers);
 177
 178 # Contact each server in turn until we succeed with one of them.
 179 my $server;
 180
 181 foreach $server (@servers)
 182   {
 183     alarm 0;
 184
 185     print "Attempting to connect to $server port 5904\n" if $verbose;
 186     syslog ("info", "exchanging cells with $server");
 187
 188     my $socket = new IO::Socket::INET (PeerAddr => $server,
 189                                        PeerPort => "5904",
 190                                        Proto => "tcp");
 191
 192     unless ($socket)
 193       {
 194         syslog ("error", "could not connect to $server");
 195         print "Failed to connect.\n" if $verbose;
 196         next;
 197       }
 198
 199     print "Connected.\n" if $verbose;
 200
 201     # Read server and protocol version.
 202     alarm 60;
 203     $_ = $socket->getline;
 204
 205     unless (/^DLIFE SERVER\s+([0-9]+\.[0-9]+)\s+([0-9]+\.[0-9]+)/)
 206       {
 207         print "Unrecognized server greeting.\n" if $verbose;
 208         next;
 209       }
 210
 211     my $server_version = $1;
 212     my $protocol_version = $2;
 213
 214     # The only protocol we recognize right now is version 1.x. These
 215     # x (minor) revisions will be backwards compatible. If an
 216     # incompatibility is introduced in the future, then that will
 217     # become version 2.x, 3.x, etc.
 218     unless ($protocol_version =~ /^1\./)
 219       {
 220         print "Unsupported protocol version.\n" if $verbose;
 221         next;
 222       }
 223
 224     # Send our client greeting string.
 225     $socket->print ("HELO - $client_version\r\n");
 226
 227     # Wait for OK response.
 228     alarm 60;
 229     $_ = $socket->getline;
 230
 231     unless (/^2[0-9][0-9]\s/)
 232       {
 233         print "Error response from server during HELO.\n" if $verbose;
 234         next;
 235       }
 236
 237     # Check for cells to upload, and upload the first few.
 238     my $cell_filename;
 239
 240     foreach $cell_filename (@upload_cells)
 241       {
 242         print "Uploading $cell_filename ...\n" if $verbose;
 243
 244         $socket->print ("STOR\r\n");
 245
 246         # Wait for OK to send response.
 247         alarm 60;
 248         $_ = $socket->getline;
 249
 250         unless (/^1[0-9][0-9]\s/)
 251           {
 252             print "Error response from server during STOR.\n" if $verbose;
 253             next;
 254           }
 255
 256         # Send the cell.
 257         open CELL, "<$cell_filename" or die "$cell_filename: $!";
 258
 259         while (<CELL>)
 260           {
 261             s/[\n\r]*$//;
 262             $socket->print ($_, "\r\n");
 263           }
 264
 265         close CELL;
 266
 267         $socket->print (".\r\n");
 268
 269         # Wait for OK response from server.
 270         alarm 60;
 271         $_ = $socket->getline;
 272
 273         unless (/^2[0-9][0-9]\s/)
 274           {
 275             print "Error response from server after STOR.\n" if $verbose;
 276             next;
 277           }
 278       }
 279
 280     # Remove all upload cells in the queue.
 281     foreach $cell_filename (@all_upload_cells)
 282       {
 283         unlink $cell_filename;
 284       }
 285
 286     # Check for cells to download.
 287     for (my $i = 0; $i < $max_cells_download_per_pass; ++$i)
 288       {
 289         print "Downloading ...\n" if $verbose;
 290
 291         $socket->print ("RETR\r\n");
 292
 293         # Wait for OK to retrieve response.
 294         alarm 60;
 295         $_ = $socket->getline;
 296
 297         unless (/^1[0-9][0-9]\s/)
 298           {
 299             print "Error response from server during RETR.\n" if $verbose;
 300             next;
 301           }
 302
 303         # Retrieve the cell.
 304         my $cell = "";
 305
 306         while (length ($cell) < 8192)
 307           {
 308             alarm 10;
 309             $_ = $socket->getline;
 310             alarm 0;
 311
 312             s/[\n\r]*$//;
 313
 314             last if $_ eq ".";
 315
 316             $cell .= $_ . "\n";
 317           }
 318
 319         # Wait for OK response.
 320         alarm 60;
 321         $_ = $socket->getline;
 322
 323         unless (/^2[0-9][0-9]\s/)
 324           {
 325             print "Error response from server after RETR.\n" if $verbose;
 326             next;
 327           }
 328
 329         # Save the cell to a file.
 330         my $rand = int (rand 1000000000);
 331         open CELL, ">incoming/$rand.dlo" or die "incoming/$rand.dlo: $!";
 332
 333         print CELL $cell;
 334
 335         close CELL;
 336       }
 337
 338     print "Disconnecting ...\n" if $verbose;
 339
 340     # Say goodbye.
 341     $socket->print ("QUIT\r\n");
 342
 343     # Wait for OK response from server.
 344     alarm 60;
 345     $_ = $socket->getline;
 346
 347     unless (/^2[0-9][0-9]\s/)
 348       {
 349         print "Error response from server during QUIT.\n" if $verbose;
 350         next;
 351       }
 352
 353     # Close socket.
 354     $socket->close;
 355
 356     alarm 0;
 357     last;
 358   }
 359
 360 syslog ("info", "exit");
 361
 362 exit;
 363
 364 sub randomize_list
 365   {
 366     for (my $i = 0; $i < @_; ++$i)
 367       {
 368         my $r = int (rand (@_ - $i));
 369
 370         if ($r > 0)
 371           {
 372             # Swap elements $i and $i+$r.
 373             my $t = $_[$i+$r];
 374             $_[$i+$r] = $_[$i];
 375             $_[$i] = $t;
 376           }
 377       }
 378
 379     return @_;
 380   }
 381
 382 # This function is equivalent to glob ("outgoing/*.dlo"), except that
 383 # the glob function doesn't work when tainting is enabled, alas.
 384 sub glob_outgoing
 385   {
 386     opendir DIR, "outgoing" or die "outgoing: $!";
 387     my @names = map { untaint_string ($_) } map { "outgoing/$_" } grep { /\.dlo$/ } readdir DIR;
 388     closedir DIR;
 389     return @names;
 390   }
 391
 392 sub untaint_string
 393   {
 394     my $s = shift;
 395     $s =~ /^(.*)$/;
 396     return $1;
 397   }