12 use Sys::Syslog qw(:DEFAULT setlogsock);
16 my $config_filename = "@CONFDIR@/client.conf";
17 my $spooldir = "@SPOOLDIR@";
18 my $client_version = "@VERSION@";
20 GetOptions ("help|?" => \$help,
21 "verbose" => \$verbose,
22 "config=s" => \$config_filename,
23 "spooldir=s" => \$spooldir);
28 dlife_client.pl [--help] [--verbose] \
29 [--spooldir=spooldir] [--config=config_file]
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).
41 # Open a connection to syslog.
43 openlog ("dlife_client", "", "user");
45 syslog ("info", "version $client_version starting [conf=$config_filename, spool=$spooldir]");
47 # Default configuration values.
49 my @server_zones = ();
51 my $max_cells_upload_per_pass = 6;
52 my $max_cells_download_per_pass = 4;
54 # Read configuration file.
55 open CONFIG, "<$config_filename" or die "$config_filename: $!";
63 if (/^\s*server_url\s+(\S+)\s*$/)
66 print "server_url=$server_url\n" if $verbose;
68 elsif (/^\s*server_zone\s+(.*)\s*$/)
70 @server_zones = split /\s+/, $1;
71 print "server_zones=", join (" ", @server_zones), "\n" if $verbose;
73 elsif (/^\s*server\s+(.*)\s*$/)
75 @servers = split /\s+/, $1;
76 print "servers=", join (" ", @servers), "\n" if $verbose;
78 elsif (/^\s*max_cells_upload_per_pass\s+([1-9][0-9]*)\s*$/)
80 $max_cells_upload_per_pass = $1;
82 elsif (/^\s*max_cells_download_per_pass\s+([1-9][0-9]*)\s*$/)
84 $max_cells_download_per_pass = $1;
88 die "unknown configuration option: $_";
94 # Load @server_zones into a hash for rapid searching.
96 foreach (@server_zones) { $server_zones{$_} = 1; }
98 # Server URL set or @servers not empty?
99 unless ($server_url || @servers)
101 die "neither server_url and servers was set: cannot do anything";
104 # Go to spool directory.
105 chdir $spooldir or die "$spooldir: $!";
107 # Find the list of cells to upload and arrange into a random order.
108 my @all_upload_cells = randomize_list (glob_outgoing ());
110 unless (@all_upload_cells)
112 syslog ("info", "no cells to upload (is the dlife_soup process running?)");
116 # Only upload the first few cells.
117 my @upload_cells = @all_upload_cells;
118 splice @upload_cells, $max_cells_upload_per_pass;
120 # If server URL set, then go and download the webpage. Load appropriate
121 # server names into @servers.
124 syslog ("info", "contacting $server_url");
125 print "Contacting $server_url\n" if $verbose;
127 my $ua = LWP::UserAgent->new;
128 my $req = HTTP::Request->new ("GET", $server_url);
129 my $rep = $ua->request ($req);
131 if ($rep->is_success)
133 print "Fetched page. Parsing page ...\n" if $verbose;
136 my @lines = split /[\n\r]+/, $rep->content;
140 if (/^\s*server\s+(\S*)\s+(.*)\s*$/)
143 my @zones = split /\s+/, $2;
145 # Is this server in one of our zones?
150 if (exists $server_zones{$_})
152 push @servers, $server;
159 push @servers, $server;
164 print "Finished parsing page. \@servers = ",
165 join (" ", @servers), "\n"
170 syslog ("error", "could not contact $server_url");
171 print "Could not contact server.\n" if $verbose;
175 # Sort the server list into a random order.
176 @servers = randomize_list (@servers);
178 # Contact each server in turn until we succeed with one of them.
181 foreach $server (@servers)
185 print "Attempting to connect to $server port 5904\n" if $verbose;
186 syslog ("info", "exchanging cells with $server");
188 my $socket = new IO::Socket::INET (PeerAddr => $server,
194 syslog ("error", "could not connect to $server");
195 print "Failed to connect.\n" if $verbose;
199 print "Connected.\n" if $verbose;
201 # Read server and protocol version.
203 $_ = $socket->getline;
205 unless (/^DLIFE SERVER\s+([0-9]+\.[0-9]+)\s+([0-9]+\.[0-9]+)/)
207 print "Unrecognized server greeting.\n" if $verbose;
211 my $server_version = $1;
212 my $protocol_version = $2;
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\./)
220 print "Unsupported protocol version.\n" if $verbose;
224 # Send our client greeting string.
225 $socket->print ("HELO - $client_version\r\n");
227 # Wait for OK response.
229 $_ = $socket->getline;
231 unless (/^2[0-9][0-9]\s/)
233 print "Error response from server during HELO.\n" if $verbose;
237 # Check for cells to upload, and upload the first few.
240 foreach $cell_filename (@upload_cells)
242 print "Uploading $cell_filename ...\n" if $verbose;
244 $socket->print ("STOR\r\n");
246 # Wait for OK to send response.
248 $_ = $socket->getline;
250 unless (/^1[0-9][0-9]\s/)
252 print "Error response from server during STOR.\n" if $verbose;
257 open CELL, "<$cell_filename" or die "$cell_filename: $!";
262 $socket->print ($_, "\r\n");
267 $socket->print (".\r\n");
269 # Wait for OK response from server.
271 $_ = $socket->getline;
273 unless (/^2[0-9][0-9]\s/)
275 print "Error response from server after STOR.\n" if $verbose;
280 # Remove all upload cells in the queue.
281 foreach $cell_filename (@all_upload_cells)
283 unlink $cell_filename;
286 # Check for cells to download.
287 for (my $i = 0; $i < $max_cells_download_per_pass; ++$i)
289 print "Downloading ...\n" if $verbose;
291 $socket->print ("RETR\r\n");
293 # Wait for OK to retrieve response.
295 $_ = $socket->getline;
297 unless (/^1[0-9][0-9]\s/)
299 print "Error response from server during RETR.\n" if $verbose;
306 while (length ($cell) < 8192)
309 $_ = $socket->getline;
319 # Wait for OK response.
321 $_ = $socket->getline;
323 unless (/^2[0-9][0-9]\s/)
325 print "Error response from server after RETR.\n" if $verbose;
329 # Save the cell to a file.
330 my $rand = int (rand 1000000000);
331 open CELL, ">incoming/$rand.dlo" or die "incoming/$rand.dlo: $!";
338 print "Disconnecting ...\n" if $verbose;
341 $socket->print ("QUIT\r\n");
343 # Wait for OK response from server.
345 $_ = $socket->getline;
347 unless (/^2[0-9][0-9]\s/)
349 print "Error response from server during QUIT.\n" if $verbose;
360 syslog ("info", "exit");
366 for (my $i = 0; $i < @_; ++$i)
368 my $r = int (rand (@_ - $i));
372 # Swap elements $i and $i+$r.
382 # This function is equivalent to glob ("outgoing/*.dlo"), except that
383 # the glob function doesn't work when tainting is enabled, alas.
386 opendir DIR, "outgoing" or die "outgoing: $!";
387 my @names = map { untaint_string ($_) } map { "outgoing/$_" } grep { /\.dlo$/ } readdir DIR;