#!/usr/bin/perl -Tw
# plgrenouille 0.61
# version 0.4 by momtchev, <momtchev@fil.univ-lille1.fr>
# modified by Pierre Etchemaite, <petchema@concept-micro.com>

# This source code is covered by the GNU GPL as found at the www.gnu.org

# ATTENTION! Ce programme est une application Linux - voir la FAQ

require 5.004;
use strict;
#use diagnostics;
use Getopt::Long qw(GetOptions);
use Fcntl qw(O_RDONLY);
use Socket qw(:DEFAULT :crlf);
#use IO::Handle qw();
use Net::hostent qw(gethost);
use Net::Ping qw();
use Net::FTP qw();

$ENV{'PATH'} = '/usr/local/sbin:%%PREFIX%%/bin:/usr/sbin:/usr/bin:/sbin:/bin';

my(%VERSION) = ( 'client' => 'plgrenouille',
		 'version' => 0.61,
		 'beta' => 0, # 0 for release versions
		 'build' => 0, # build numbers imply linear development,
		               # so they are foreign to free dev world
		               # where anyone can fork his own version
		 'system' => $^O );

my $PREFIX ||= '/usr/local';
my $MYRC ||= "$PREFIX/etc/grenouillerc";
my $DATAPATH ||= '/var/spool/plgrenouille';
my $DOWNLOADFILE ||= "$DATAPATH/downloadfile";
my $UPLOADFILE ||= "$DATAPATH/uploadfile";
my $QUEUEFILE ||= "$DATAPATH/queued_results.txt";
my $LASTCONFIGFILE ||= "$DATAPATH/last_configuration.txt";
my $LASTVERSIONFILE ||= "$DATAPATH/last_known_version.txt";
my $PIDFILE ||= "/var/run/plgrenouille.pid";
my $LOGFILE ||= "/var/log/plgrenouille.log";
my $NETSTAT ||= '/usr/bin/netstat';
my $IFCONFIG ||= '/sbin/ifconfig';

my $USER ||= 'daemon';

# what features do we want to debug ?
my(%DEBUG) = ( 'protocol' => 0, 'scheduler' => 0 );

my(%LOG_PRIORITY) = ('DEBUG'=>1, 'INFO'=>2,
		     'NOTICE'=>3, 'DISPLAY'=>4, 'LOG'=>5,
                     'WARNING'=>6, 'ERROR'=>7);

my($LOG_LEVEL) = $LOG_PRIORITY{'LOG'};
my($DISPLAY_LEVEL) = $LOG_PRIORITY{'INFO'};

# ---------------------------------------------------------------

my $ASAP ||= 0;
my $SEC ||= 1000;
my $MIN ||= 60 * $SEC;
my $HOUR ||= 60 * $MIN;
my $DAY ||= 24 * $HOUR;
my(@MONTHS) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

sub usage($) {
    my($exitcode) = @_;
    display_version();
    print <<"EOUSAGE";
Usage: $VERSION{'client'} [-c|--configure] [-b|--background] [-h|-?|--help]
              [[-l |--log=]priorit] [[-v |--verbose=]priorit]

priorit: [debug | info | notice | warning | error]

--configure: (re)configuration
--background: passe en dtach
--log: change le niveau de dtail du log (def. notice)
--verbose: change le niveau de dtail de l'affichage (def. info)
--help: cette aide

EOUSAGE
    exit($exitcode);
}

sub swap_privileges() {
    ($<, $>) = ($>, $<);
    ($(, $)) = ($), $();
}

sub init_grenouille() {
    my(undef, undef, $uid, $gid) = getpwnam($USER) or 
	die "$USER absent de /etc/password";

    $< = $uid;
    $( = $gid;

    die "Dsol, ce programme doit avoir les droits de root pour pouvoir envoyer des pings ICMP" if $>;
 
    swap_privileges();

# disable debugging in official releases
    %DEBUG = () unless $VERSION{'beta'};
    
    die "$DATAPATH n'existe pas!" unless -d $DATAPATH;
}

# for milliseconds; otherwise would use built-in time.

my $SYS_gettimeofday ||= 116;

sub microtime() {
    my ($timeval, $timezone, $sec, $usec);
    
    $timeval = $timezone = ("\0" x 4) x 2;
    
    syscall($SYS_gettimeofday, $timeval, $timezone)
	&& die "gettimeofday failed: $!";
    
    ($sec, $usec) = unpack('L2', $timeval);
    return ($sec * $SEC) + ($usec / (1000000 / $SEC));
}

# fine grained sleep, credits: man perlfunc
sub usleep($) {
    select(undef, undef, undef, shift);
}

sub open_log() {
    if($LOGFILE) {
	# logging is important for security, give up if logging is not
	# available - undef $LOGFILE if you really mean it
	open(LOG, ">>$LOGFILE") or die "$LOGFILE: $!";
	autoflush LOG 1;
	_log('-- log start --');
	schedule_event(microtime() + 20 * $MIN, \&mark_log);
    }
}

sub mark_log($) { # EVENT
    my($schedule_time) = shift;
    _log('-- mark --');
    schedule_event($schedule_time + 20 * $MIN, \&mark_log);
}

sub close_log() {
    if($LOGFILE and stat LOG) {
	_log('-- log end --');
	close LOG;
    }
}

sub _log($) {
    my($msg) = @_;
    my($sec, $min, $hour, $mday, $mon, 
       undef, undef, undef, undef) = localtime();
    printf(LOG "%s %2s %02d:%02d:%02d %s\n", $MONTHS[$mon], $mday, 
                                             $hour, $min, $sec, $msg);
}

my (%DISPLAY_PREFIX) = ('DISPLAY'=>'', 'NOTICE'=>'');
my (%LOG_PREFIX) = ('LOG'=>'', 'NOTICE'=>'');

sub display_and_log($$) {
    my($level, $msg) = @_;
    my($nlevel) = $LOG_PRIORITY{$level};
    die "unknown priority $level" unless $nlevel;
    if(($nlevel != $LOG_PRIORITY{'LOG'}) and 
       (($nlevel == $LOG_PRIORITY{'DISPLAY'}) or 
        ($nlevel >= $DISPLAY_LEVEL))) {
	my($prefixed_msg) = (exists $DISPLAY_PREFIX{$level} ? $DISPLAY_PREFIX{$level} : "[$level] ") . $msg;
	if($nlevel > $LOG_PRIORITY{'NOTICE'}) {
	    print STDERR "$prefixed_msg\n";
	} else {
	    print "$prefixed_msg\n";
	}
    }
    if($LOGFILE and ($nlevel != $LOG_PRIORITY{'DISPLAY'}) and 
       (($nlevel == $LOG_PRIORITY{'LOG'}) or ($nlevel >= $LOG_LEVEL))) {
	_log((exists $LOG_PREFIX{$level} ? $LOG_PREFIX{$level} : "[$level] ") . $msg);
    }
}

sub set_log_level($$) {
  my($opt, $level) = @_;
  $LOG_LEVEL = $LOG_PRIORITY{uc($level)};
  die "Priorit $level inconnue" unless $LOG_LEVEL;
}

sub set_verbose_level($$) {
  my($opt, $level) = @_;
  $DISPLAY_LEVEL = $LOG_PRIORITY{uc($level)};
  die "Priorit $level inconnue" unless $DISPLAY_LEVEL;
}

# parse netstat -ib (FreeBSD)
sub get_traffic_counters($) {
    my ($if_device) = @_;
    
    open(NETSTAT_PIPE, '-|') or exec($NETSTAT, '-ib') or die "netstat: $!";
    while (<NETSTAT_PIPE>) {
	if (/^($if_device.*<Link.*)/) {
	    my(@counters) = split(/\s+/, $1);
	    close(NETSTAT_PIPE);
	    return { 'rx' => $counters[6],
		     'tx' => $counters[9] };
	}
    }
    
    close(NETSTAT_PIPE);
    die "Pas d'interface $if_device ?";
}

# lame scrambling algorithm
sub crypt_pass($) {
    my ($pass) = lc shift;
    my ($seed, $i, $p, $c, $crypt);
    
    $seed = 'pasfaciledetrouverlaclefpourouvrirlaporte';
    $crypt = '';
    for ($i = 0; $i < length $pass; $i++) {
	$p = ord(substr($pass, $i, 1));
	$c = ord(substr($seed, $i, 1));
	if ($p >= ord('a') and $p <= ord('z')) {
	    $crypt = chr(($p + $c) % 26 + ord('a')) . $crypt;
	}
	elsif ($p >= ord('0') and $p <= ord('9')) {
	    $crypt = chr(($p + $c) % 10 + ord('0')) . $crypt;
	}
	else {
	    $crypt = '_' . $crypt;
	}
    }
    
    return $crypt;
}

# truncate to n digits, rounding last one
sub digits($$) {
    my($value, $n) = @_;
    my($f) = 10 ** $n;
    return int($value * $f + 0.5) / $f;
}

# return a value between $x + $jmin % and $x + $jmax %
sub jitter($$$) {
    my($x, $jmin, $jmax) = @_;
    return $x * (1 + ($jmin + rand ($jmax - $jmin)) / 100);
}

# pretty-print a FTP URL
sub ftp_url($$$) {
    my($site, $path, $filename) = @_;
    my($result) = "$site/$path/$filename";
    $result =~ s!^/+!!;
    $result =~ s!//+!/!g;
    return "ftp://$result";
}

# randomly pick one of the IP addresses of a hostname
sub pick_host_addr($) {
    my($dns_name) = @_;
    my($h) = gethost($dns_name);
    return undef unless $h and scalar @{$h->addr_list};
    return inet_ntoa(@{$h->addr_list}[rand scalar @{$h->addr_list}]);
}

my $SERVERNAME ||= 'www.grenouille.com';
my $SENDRETRIES ||= 2;

sub contact_server($) {
    my ($string) = @_;
    my ($ip, $tries, %result, $command);
    
    $command = "GET /interface.php?$string HTTP/1.0";
    if($DEBUG{'protocol'}) {
        my($display) = $command;
        $display =~ s/((?:^|&)password=)[^&]*/$1******/g;
        display_and_log('DEBUG', $display);
    }

    for($tries=0;$tries < $SENDRETRIES;$tries++) {
	eval {
	    socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or
		die "socket: $!";
	    $ip = inet_aton($SERVERNAME) or die "host: $!";
	    connect(SOCK, sockaddr_in(80, $ip)) or die "connect: $!";
	    
	    autoflush SOCK 1;
	    
	    print SOCK "${command}$CRLF" .
		"Host: ${SERVERNAME}$CRLF" .
		"User-Agent: $VERSION{'client'} $VERSION{'version'}$CRLF" .
		$CRLF;
	    
	    while(<SOCK>) {
		if (/([^=]+)=([^=]+)/) {
		    $result{$1} = $2;
		    chomp($result{$1});
		}
	    }
	    
	    close(SOCK);
	    display_and_log('WARNING', "Serveur: $result{'warning'}") if $result{'warning'};
	    exists $result{'result'} and $result{'result'} =~ /OK/ or
		die "Server responded error \"$result{'error'}\"";
	};
	last unless $@;
	sleep jitter(15, 0, 5);
    }
    die if $@;
    
    return %result;
}

# --------------------------- INITIALISATION ----------------------------

my (%config, %preferences, %params, %vars);

sub init_vars() {
    init_result_queue();
    load_result_queue();
}

sub load_preferences() {
    swap_privileges();
    eval {
	if (open(CONFIG, "<$MYRC")) {
	    while (<CONFIG>) {
		chomp;
		s/#.*$//;
		$preferences{$1} = $2 if /^([^=]*)=(.*)$/;
	    }
	    close(CONFIG);
	}
    };
    die if $@;
    swap_privileges();
}

sub store_preferences() {
    my($oldumask) = umask 0177;
    swap_privileges();
    eval {
	if(open(CONFIG, ">$MYRC")) {
	    map { print CONFIG "$_=$preferences{$_}\n"; } sort keys %preferences;
	    close(CONFIG);
	} else {
	    display_and_log('WARNING', "Ecriture du fichier $MYRC impossible: vrifier les permissions");
	}
    };
    swap_privileges();
    umask $oldumask;
    die if $@;
}

sub _ask($$$) {
    my($msg, $type, $default) = @_;
    my($answer);
    print $msg;
    if(defined $default) {
	print ' (';
	print $default ? 'O/n' : 'o/N' if $type eq 'boolean';
	print $default if $type eq 'string';
	print '******' if $type eq 'hidden_string';
	print ')';
    }
    print ': ';
    chomp($answer = <STDIN>);
    return $default unless $answer;
    return $answer !~ /n/ ? 1 : 0 if $type eq 'boolean';
    return $answer if ($type eq 'string') or ($type eq 'hidden_string');
    die 'unknown answer type';
}

sub ask_preferences() {
 
    die 'Ce programme doit tre lanc interactivement pour tre configur' unless -t STDIN and -t STDOUT;

    load_preferences();
    
    print "\nEntrez les valeurs qui vous ont servi  vous enregistrer sur grenouille.com :\n\n";
    $preferences{'user'} = _ask('Pseudo', 'string', $preferences{'user'});

    $preferences{'pass'} = _ask('Mot de passe', 'hidden_string', $preferences{'pass'});

    $preferences{'email'} = _ask('Adresse email', 'string', $preferences{'email'});

    print "\nVeuillez spcifier vos prfrences :\n";

    $preferences{'test_upload'} = _ask(
       "\nATTENTION:\nCertains abonnements (en gnral le cable) imposent des restrictions en\n" .
       "upload; La mesure de l'upload peut consommer une portion non ngligeable\n" .
       "de votre forfait.\nMesurer l'upload", 
       'boolean', defined $preferences{'test_upload'} ? ($preferences{'test_upload'} ne '0') : 1);

    $preferences{'passive_ftp'} = _ask(
       "\nPour des raisons de compatibilit et de scurit, le mode FTP \"passif\"\n" .
       "est aujourd'hui le mode FTP de prdilection.\n" .
       "(lire http://cr.yp.to/ftp/security.html pour plus d'informations)\n" .
       'Voulez-vous utiliser FTP en mode passif', 
       'boolean', defined $preferences{'passive_ftp'} ? ($preferences{'passive_ftp'} ne '0') : 1);

    $preferences{'email_notification'} = _ask(
      "\nSi vous comptez lancer plgrenouille automatiquement au boot, il n'aura\n" .
      "probablement aucune chance de pouvoir vous avertir lors de la sortie de\n" .
      "nouvelles versions.\n" .
      'Voulez-vous tre averti des nouvelles versions par email', 
      'boolean', defined $preferences{'email_notification'} ? ($preferences{'email_notification'} ne 0) : 1);
    
    print "\nLa configuration sera sauvegarde dans $MYRC\n";
    store_preferences();
}

sub get_preferences() {
    load_preferences();
    
    die "plgrenouille n'a pas t totalement paramtr, lancez plgrenouille --config ou modifiez $MYRC"
	if not defined $preferences{'user'} or 
	   not defined $preferences{'pass'} or
	   not defined $preferences{'email'} or 
	   not defined $preferences{'test_upload'} or
	   not defined $preferences{'email_notification'} or
	   not defined $preferences{'passive_ftp'};
}

# --------------------------- INTERFACE ----------------------------

# plgrenouille uses the default route interface
sub autodetect_interface() {
    $vars{'ip'} = '';
    open(ROUTE_PIPE, '-|') or exec($NETSTAT, '-r') or die "netstat: $!";
    while (<ROUTE_PIPE>) {
      if (/^default.* ([^ ]+[0-9]+)$/) {
	    $preferences{'interface'} = $1;
      }
    }
    close(ROUTE_PIPE);
    open(IFCONFIG_PIPE, '-|') or exec($IFCONFIG, $preferences{'interface'}) or die "ifconfig: $!";
    while(<IFCONFIG_PIPE>) {
	if (/inet ([.0-9]+)/) {
	    $vars{'ip'} = $1;
	}
    }
    close(IFCONFIG_PIPE);
    
    display_and_log('NOTICE', "$preferences{'interface'} sera utilis pour les mesures") if $preferences{'interface'};
}

sub interface_up() {
    if($preferences{'interface'}) {
	eval {
	    # will fail if the interface disappeared under us
	    my($dummy) = get_traffic_counters($preferences{'interface'});
	};
	if ($@) {
	    display_and_log('NOTICE', "L'interface $preferences{'interface'} a disparu: $@");
	    delete $preferences{'interface'};
	}
    }
    autodetect_interface() unless $preferences{'interface'};

    return $preferences{'interface'};
}

# --------------------------- SCHEDULER ----------------------------
# events are scheduled "optimistically" by other events, so
# it's up to each event handler to check, when scheduled,
# if it can really run.
#
# a given event handler cannot be scheduled more than once 
# (the "soonish" schedule wins).

my(@events) = ();

sub clear_all_events() {
    @events = ();
}

sub get_next_event() {
    die 'No event to wait for!' unless scalar @events;
    my($nextevent) = shift @events;
    my($wait) = ($nextevent->{'time'} - microtime()) / $SEC;
    if ($wait > 0) {
	print "(pause de $wait secondes...)" if $DEBUG{'scheduler'};
	usleep($wait);
	print "\n" if $DEBUG{'scheduler'};
    }
    return $nextevent;
}

sub schedule_event($$) {
    my($new_event) = { 'time' => $_[0], 'action' => $_[1] };
    my($now) = microtime();
    if($_[0] < $now) {
	display_and_log('WARNING', 'We cannot schedule an event in the past...') unless $_[0] == $ASAP;
	$new_event->{'time'} = $now;
    }
    
  INSERT: {
      my($i, @nevents);
      for($i = 0; $i < scalar @events;$i++) {
	  last if $new_event->{'time'} < $events[$i]->{'time'};
	  last INSERT if $events[$i]->{'action'} == $new_event->{'action'};
	  push @nevents, $events[$i];
      }
      push @nevents, $new_event;
      for(; $i < scalar @events;$i++) {
	  push @nevents, $events[$i] unless $events[$i]->{'action'} == 
                                            $new_event->{'action'};
      }
      @events = @nevents;
  }
}

# --------------------------- RESULTS QUEUING ----------------------------

my(@result_queue) = ();

# dumping result queue to disk allow it to survive program reloads,
# but this is not strictly required for correct working
my($queue_storage_ok) = 1;

# Could we "tie" the queue structure to avoid explicit storage instructions ?

sub store_result_queue() {
    if($queue_storage_ok) {
	if(open(QUEUE, ">$QUEUEFILE")) {
	    map { print QUEUE "$_->{'time'}\n$_->{'string'}\n~\n" } 
              @result_queue;
	    close QUEUE;
	} else {
	    display_and_log('WARNING', "Impossible de mettre  jour $QUEUEFILE, critures dsactives");
	    $queue_storage_ok = 0;
	}
    }
}

sub load_result_queue() {
    if(open(QUEUE, "<$QUEUEFILE")) {
	while(not eof(QUEUE)) {
	    my($time, $string, $sep);
	    chomp($time = <QUEUE>);
	    chomp($string = <QUEUE>);
	    chomp($sep = <QUEUE>); # $sep is for consistency checking
	    push @result_queue, { 'time' => $time,
				  'string' => $string } if $sep eq '~';
	}
    }
}

sub init_result_queue() {
    @result_queue = ();
}

sub send_results($) { # EVENT
    my($schedule_time) = shift;
    return unless $vars{'id'};
    return unless scalar @result_queue;
    
    my ($result) = $result_queue[0];
    my ($result_age) = digits((microtime() - $result->{'time'}) / $SEC, 0);
    eval {
        contact_server("$result->{'string'}&id=$vars{'id'}&elapsed_seconds=$result_age");
    };
    if($@) {
	if($@ =~ /^Server responded error/) {
	    display_and_log('ERROR', $@);
	    if ($@ =~ /Identifiant d.utilisateur incorrect/) {
		display_and_log('INFO', "session expire, ouverture d'une nouvelle session");
                delete $vars{'id'};
		schedule_event($ASAP, \&open_session);
	    } else {
		# unidentified (possibly serious) problem encountered, 
		# drop the result to avoid looping
		display_and_log('WARNING', "type d'erreur non reconnu, annulation de l'envoi");
		shift @result_queue;
		store_result_queue();
	    }
	} else {
	    display_and_log('INFO', "Problme temporaire de connexion avec le serveur $SERVERNAME");
	}
	schedule_event(microtime() + jitter(5 * $MIN, -1, 1), \&send_results);
    } else {
	shift @result_queue;
	store_result_queue();
	schedule_event(microtime() + 5 * $SEC, \&send_results);
    }
}

sub queue_result($) {
    my ($result) = { 'string' => $_[0], 'time' => microtime() };
    push @result_queue, $result;
    store_result_queue();
    schedule_event($ASAP, \&send_results);
}

# --------------------------- EVENT HANDLERS ----------------------------

sub open_session($) { # EVENT
    my($schedule_time) = shift;
    return if $vars{'id'};
    
    # the server wants to know the IP (from our pov), check the interface
    # earlier than we used to
    interface_up();

    my($pass, %answer);
    $pass = crypt_pass($preferences{'pass'});
    eval {
	%answer = contact_server("command=hello&username=$preferences{'user'}&password=$pass&system=$VERSION{'system'}&client=$VERSION{'client'}&version=$VERSION{'version'}" . ($VERSION{'beta'} ? "&beta=$VERSION{'beta'}" : '') . "&ip=$vars{'ip'}");
    };
    if(not $@) {
	display_and_log('INFO', "Ouverture de session");
	$vars{'id'} = $answer{'id'};
	schedule_event($ASAP, \&read_config);
        schedule_event($ASAP, \&send_results);
	schedule_event($ASAP, \&check_last_version);
    } else {
	display_and_log('INFO', "Ouverture de session impossible pour l'instant ($@)");
	schedule_event($schedule_time + jitter(5 * $MIN, 0, 5), \&open_session);
	# for now, run tests with saved parameters
	schedule_event($ASAP, \&read_config);
    }
}

sub test_ping($) { # EVENT
    my($schedule_time) = shift;
    return unless $config{'ping_host'};
    if(not interface_up()) {
	schedule_event(microtime() + jitter(1 * $MIN, -1, 1), \&test_ping);
	return;
    }
    display_and_log('INFO', "Ping de $config{'ping_host'}...");
    my($h) = pick_host_addr($config{'ping_host'});
    if(not $h) {
	display_and_log('WARNING', 'Serveur DNS indisponible ?');
	schedule_event(microtime() + jitter(5 * $MIN, 0, 5), \&test_ping);
	return;
    }
    
    my ($p);
    swap_privileges();
    $p = Net::Ping->new('icmp', 5, length($config{'ping_string'}));
    swap_privileges();
    # ugly, but Net::Ping doesn't allow to specify the string
    $p->{"data"} = $config{'ping_string'};

    my($sent, $received, $total_time) = (0, 0, 0);
    while($sent < $config{'ping_quantity'}) {
	my($start_time, $stop_time);
	$sent++;
	$start_time = microtime();
	if ($p->ping($h)) {
	    $stop_time = microtime();
	    $total_time += $stop_time - $start_time;
	    $received++;
	}
	else {
	    display_and_log('INFO', "Ping de $config{'ping_host'} perdu");
	}
	usleep(jitter(1 * $SEC, -1, 1) / $SEC);
    }
    $p->close();
	
    queue_result("command=post_ping&sent=$sent&received=$received&total_time=" . digits($total_time, 2));
	
    my($lost, $rtt);
    $lost = digits((1- $received / $sent) * 100, 1);
    $rtt = $received ? digits($total_time / $received,0) . ' ms' : 'N/A';
    display_and_log('LOG', "PING host=$config{'ping_host'} sent=$sent received=$received total_time=" . digits($total_time, 2));
    display_and_log('DISPLAY', "Pings OK, RTT $rtt, perdu $lost%");
	
    schedule_event($schedule_time + jitter($config{'ping_frequency'} * $SEC, -1, 1), \&test_ping);
}

# credit: man perlfaq4
# fisher yates shuffle: generate a random permutation of array in place
sub shuffle($) {
    my($array) = $_[0];
    my($i);
    for ($i = scalar @$array; --$i; ) {
        my($j) = int rand ($i+1);
        @$array[$i,$j] = @$array[$j,$i] unless $i == $j;
    }
}

my $ALIVETRIES ||= 5;

sub test_breakdown($) { # EVENT
    my($schedule_time) = shift;
    return unless scalar %config;
    if(not interface_up()) {
	schedule_event(microtime() + jitter(1 * $MIN, 0, 5), \&test_breakdown);
	return;
    }

    # parse breakdown_host into an arrayref
    my(@list_to_go) = map { s/^\s+//; s/\s+$//; $_ } split(/,/, $config{'breakdown_host'});
    return unless scalar @list_to_go;
    # not required by specs, but adds to the fun
    shuffle(\@list_to_go);

    my ($p, $host, $alive);
    swap_privileges();
    $p = Net::Ping->new('icmp', 5, length($config{'ping_string'}));
    swap_privileges();
    # ugly, but Net::Ping doesn't allow to specify the string
    $p->{"data"} = $config{'ping_string'};
    $alive = 0;

  HOSTS: foreach $host (@list_to_go) {
      display_and_log('INFO', "Ping d'une adresse ($host)...");
      my($h) = pick_host_addr($host);
      if(not $h) {
	  display_and_log('WARNING', 'Serveur DNS indisponible ?');
      } else {
	  my($tries);
	  for($tries=0;$tries < $ALIVETRIES; $tries++) {
	      if($p->ping($h)) {
		  $alive = 1;
		  last HOSTS;
	      }
	      usleep(jitter(1 * $SEC, -1, 1) / $SEC);
	  }
      }
  }
    $p->close();
    
    if (not $alive) {
	# we exhausted the list, none replied
	display_and_log('LOG', "BREAKDOWN link=down hosts=$config{'breakdown_host'}");
	display_and_log('DISPLAY', 'La connexion semble morte !');
	queue_result("command=post_breakdown");
    } else {
	display_and_log('LOG', 'BREAKDOWN link=up');
	display_and_log('DISPLAY', 'Connexion OK');
    }

    schedule_event($schedule_time + jitter($config{'breakdown_frequency'} * $SEC, -1, 1), \&test_breakdown);
}

sub test_dl($) { # EVENT
    my($schedule_time) = shift;
    return unless $config{'dl_host'};
    if(not interface_up()) {
	schedule_event(microtime() + jitter(1 * $MIN, 0, 5), \&test_dl);
	return;
    }
    display_and_log('DISPLAY', 'Chargement de ' . ftp_url($config{'dl_host'}, $config{'dl_path'}, $config{'dl_file'}) . '...');
    my($h) = pick_host_addr($config{'dl_host'});
    if(not $h) {
	display_and_log('WARNING', 'Serveur DNS indisponible ?');
	schedule_event(microtime() + jitter(1 * $MIN, 0, 5), \&test_dl);
	return;
    }
    
    my ($dl, $start_time, $stop_time, $success,
	$start_traffic_counters, $stop_traffic_counters,
	$dl_bandwidth, $dl_total_bandwidth, $ul_total_bandwidth,
	$ratio_same_direction, $ratio_opposite_direction,
	$local_file, @file_stats);
    
    $success = 0;
    $dl = undef;
    eval {
	$dl = Net::FTP->new($h, 'Passive' => $preferences{'passive_ftp'}) or die "Couldn't create Net::FTP object";
	$dl->login('anonymous', $preferences{'email'}) or 
	    die "Login failure at $config{'dl_host'}";
	$dl->cwd($config{'dl_path'}) or
	    die "Can't change directory to $config{'dl_path'}";
	$dl->binary() or
	    die "Can't change transfer mode to binary";
	$start_traffic_counters = get_traffic_counters($preferences{'interface'});
	$start_time = microtime();
	{
	    # ugly, avoid a "use of undefined variable" at Net::FTP::I.pm:29
	    local $SIG{__WARN__} = sub { };
	    $local_file = $dl->get($config{'dl_file'}, $DOWNLOADFILE) or
		die "Can't open remote file $config{'dl_file'}";
	}
	$stop_time = microtime();
	$stop_traffic_counters = get_traffic_counters($preferences{'interface'});
	$success = 1;
    };
    $dl->quit() if defined $dl;
    display_and_log('ERROR', $@) if $@;
    if ($success and not (@file_stats = stat($local_file))) {
	display_and_log('WARNING', "Fichier tlcharg $local_file incomplet");
	$success = 0;
    }
    unlink $local_file if defined $local_file;
    if ($success) {
	$dl_bandwidth = digits(
           ($file_stats[7] / 1024) / (($stop_time - $start_time) / $SEC), 2);
	$dl_total_bandwidth = digits(
           (($stop_traffic_counters->{'rx'} - $start_traffic_counters->{'rx'}) / 1024)
	    / (($stop_time - $start_time) / $SEC), 2);
	$ul_total_bandwidth = digits(
           (($stop_traffic_counters->{'tx'} - $start_traffic_counters->{'tx'}) / 1024)
	    / (($stop_time - $start_time) / $SEC), 2);
	$ratio_same_direction = int(($dl_total_bandwidth / $dl_bandwidth - 1) * 100);
	$ratio_opposite_direction = int(($ul_total_bandwidth / $dl_bandwidth) * 100);
	
	if (($dl_total_bandwidth < 0) or ($ratio_same_direction < 0)) {
	    display_and_log('WARNING', "compteurs d'octets de l'interface trop faibles, rsultat rejet !");
	    delete $preferences{'interface'};
	    $success = 0;
	}
	if ($ratio_same_direction > $config{'dl_ratiomaxdl'}) {
	    display_and_log('WARNING', 'Traffic descendant trop lev durant le test, rsultat rejet');
	    $success = 0;
	}
	if ($ratio_opposite_direction > $config{'dl_ratiomaxul'}) {
	    display_and_log('WARNING', 'Traffic montant trop lev durant le test, rsultat rejet');
	    $success = 0;
	}
    }
    if ($success) {
	if ($config{'dl_max'} and ($dl_bandwidth > $config{'dl_max'})) {
	    display_and_log('WARNING', "Bande passante mesure (${dl_bandwidth} Ko/s) > bande passante maximale prvue ($config{'dl_max'} Ko/s)");
#	    $dl_bandwidth=1.03 * $config{'dl_max'};
	}
	queue_result("command=post_dl&bandwidth=$dl_bandwidth");
	display_and_log('LOG', "DOWNLOAD bandwidth=$dl_bandwidth ratiodl=$ratio_same_direction ratioul=$ratio_opposite_direction host=$config{'dl_host'}");
	display_and_log('DISPLAY', "Chargement OK, ${dl_bandwidth} Ko/s (ratio dl=$ratio_same_direction%, ratio ul=$ratio_opposite_direction%)");
    }
    if ($success) {
	schedule_event($schedule_time + jitter($config{'dl_frequency'} * $SEC, -1, 1), \&test_dl);
    } else {
	schedule_event($schedule_time + jitter($config{'dl_frequency'} / 2 * $SEC, -1, 1), \&test_dl);
    }
}

sub test_ul($) { # EVENT
    my($schedule_time) = shift;
    return unless $preferences{'test_upload'};
    return unless $config{'ul_host'};
    if(not interface_up()) {
	schedule_event(microtime() + jitter(1 * $MIN, 0, 5), \&test_ul);
	return;
    }
    display_and_log('DISPLAY', 'Envoi de ' . ftp_url($config{'ul_host'}, $config{'ul_path'}, $config{'ul_file'}) . '...');
    my($h) = pick_host_addr($config{'ul_host'});
    if(not $h) {
	display_and_log('WARNING', 'Serveur DNS indisponible ?');
	schedule_event(microtime() + jitter(1 * $MIN, 0, 5), \&test_ul);
	return;
    }
    
    my ($ul, $start_time, $stop_time, $success,
	$start_traffic_counters, $stop_traffic_counters,
	$ul_bandwidth, $ul_total_bandwidth, $dl_total_bandwidth,
	$ratio_same_direction, $ratio_opposite_direction,
	$local_file, $remote_size);
    
    $success = 0;
    $ul = undef;
    eval {
	$ul = Net::FTP->new($h, 'Passive' => $preferences{'passive_ftp'}) or die "Couldn't create Net::FTP object";
	$ul->login('anonymous', $preferences{'email'}) or 
	    die "Login failure at $config{'ul_host'}";
	$ul->cwd($config{'ul_path'}) or
	    die "Can't change directory to $config{'ul_path'}";
	$ul->binary() or
	    die "Can't change transfer mode to binary";
	$start_traffic_counters = get_traffic_counters($preferences{'interface'});
	$start_time = microtime();
	$local_file = $ul->put($UPLOADFILE, $config{'ul_file'}) or
	    die "Can't open remote file $config{'ul_file'}";
#	$remote_size = $ul->size($config{'ul_file'});
#	if (not defined $remote_size) {
#	    display_and_log('WARNING', 'Impossible d'obtenir la taille du fichier envoy, soyons optimistes');
	    $remote_size = $config{'ul_size'} * 1024;
#	}
	$stop_time = microtime();
	$stop_traffic_counters = get_traffic_counters($preferences{'interface'});
	$success = 1;
	$ul->delete($config{'ul_file'});
#	$ul->quit(); $ul = undef;
#	$stop_time = microtime();
#	$stop_traffic_counters = get_traffic_counters($preferences{'interface'});
    };
    $ul->quit() if defined $ul;
    display_and_log('ERROR', $@) if $@;
    if ($success and (defined $remote_size)  and ($remote_size ne $config{'ul_size'} * 1024)) { 
	display_and_log('WARNING', "Envoi de $local_file interrompu");
	$success = 0;
    }
    if ($success) {
	$ul_bandwidth = digits(
           ($remote_size / 1024) / (($stop_time - $start_time) / $SEC), 2);
	$ul_total_bandwidth = digits(
           (($stop_traffic_counters->{'tx'} - $start_traffic_counters->{'tx'}) / 1024)
	    / (($stop_time - $start_time) / $SEC), 2);
	$dl_total_bandwidth = digits(
	   (($stop_traffic_counters->{'rx'} - $start_traffic_counters->{'rx'}) / 1024)
            / (($stop_time - $start_time) / $SEC), 2);
	$ratio_same_direction = int(($ul_total_bandwidth / $ul_bandwidth - 1) * 100);
	$ratio_opposite_direction = int(($dl_total_bandwidth / $ul_bandwidth) * 100);
	
	if (($ul_total_bandwidth < 0) or ($ratio_same_direction < 0)) {
	    display_and_log('WARNING', "compteurs d'octets de l'interface trop faibles, rsultat rejet !");
	    delete $preferences{'interface'};
	    $success = 0;
	}
	if ($ratio_same_direction > $config{'ul_ratiomaxul'}) {
	    display_and_log('WARNING', 'Traffic montant trop lev durant le test, rsultat rejet');
	    $success = 0;
	}
	if ($ratio_opposite_direction > $config{'ul_ratiomaxdl'}) {
	    display_and_log('WARNING', 'Traffic descendant trop lev durant le test, rsultat rejet');
	    $success = 0;
	}
    }
    if ($success) {
	if ($config{'ul_max'} and ($ul_bandwidth > $config{'ul_max'})) {
	    display_and_log('WARNING', "Bande passante mesure (${ul_bandwidth} Ko/s) > bande passante maximale prvue ($config{'ul_max'} Ko/s)");
#	    $ul_bandwidth=1.03 * $config{'ul_max'};
	}
	queue_result("command=post_ul&bandwidth=$ul_bandwidth");
	display_and_log('LOG', "UPLOAD bandwidth=$ul_bandwidth ratioul=$ratio_same_direction ratiodl=$ratio_opposite_direction host=$config{'ul_host'}");
	display_and_log('DISPLAY', "Envoi OK, ${ul_bandwidth} Ko/s (ratio ul=$ratio_same_direction%, ratio dl=$ratio_opposite_direction%)");
	
    }
    if ($success) {
	schedule_event($schedule_time + jitter($config{'ul_frequency'} * $SEC, -1, 1), \&test_ul);
    } else {
	schedule_event($schedule_time + jitter($config{'ul_frequency'} / 2 * $SEC, -1, 1), \&test_ul);
    }
}

# --------------------------- CONFIGURATION ----------------------------

sub store_config($$) {
    my($chash, $filename) = @_;
    open(FN, ">$filename") or die "$filename: $!";
    map { print FN "$_=$chash->{$_}\n"; } sort keys %$chash;
    close FN;
}

sub load_config($) {
    my($filename) = @_;
    my(%chash) = ();
    if(open(FN, "<$filename")) {
	while(<FN>) {
	    chomp;
	    $chash{$1} = $2 if /^([^=]*)=(.*)$/;
	}
	close FN;
    }
    return %chash;
}

sub _eqhash($$) {
    my($rh1, $rh2) = @_;
    return 0 unless scalar keys %$rh1 == scalar keys %$rh2;
    my($k, $v);
    while(($k, $v) = each %$rh1) {
	return 0 unless exists $rh2->{$k} and ($rh2->{$k} eq $v);
    }
    return 1;
}

sub read_config($) { # EVENT
    my($schedule_time) = shift;
    my ($modified) = 0;
    if($vars{'id'}) {
	my(%read_config);
	eval {
	    %read_config = contact_server("command=get_config&id=$vars{'id'}");
	};
	if (not $@) {
	    $modified = not _eqhash(\%config, \%read_config);
	    if($modified) {
		%config = %read_config;
		store_config(\%config, $LASTCONFIGFILE);
	    }
	    schedule_event($schedule_time + $config{'config_timetolive'} * $SEC, \&read_config);
	} else {
	    display_and_log('WARNING', "Impossible d'obtenir des paramtres de configuration  jour pour l'instant !");
	    schedule_event(microtime() + jitter(10 * $MIN, 0, 5), \&read_config);
	}
    }

    # old config is better than no config;
    # also, we do not reschedule, open_session should be already scheduled
    # and it will in turn schedule read_config 
    if(not scalar %config) {
	%config = load_config($LASTCONFIGFILE);
	if(scalar %config) {
	    $modified = 1;
	    display_and_log('INFO', 'Utilisation de la configuration sauvegarde');
	}
    }

    if($modified) {
	display_and_log('INFO', 'Prise en compte des paramtres');
	if ($config{'ul_host'} and 
	    (not (-f $UPLOADFILE) or 
	     ((-s $UPLOADFILE) != $config{'ul_size'} * 1024))) {
	    my($i,$j);
	    display_and_log('INFO', "Cration d'un fichier de $config{ul_size} Ko pour les tests d'envoi...");
	    eval {
		open(DUMMY, ">$UPLOADFILE") or die "impossible d'ouvrir $UPLOADFILE: $!";
		for($i=0;$i < $config{'ul_size'};$i++) {
		    my($buffer) = '';
		    for($j=0;$j < 1024;$j++) {
			# we use random bytes to defeat any link compression
			$buffer .= pack('C', rand 256);
		    }
		    print DUMMY $buffer or die "impossible d'crire dans $UPLOADFILE: $!";
		}
		close(DUMMY);
	    };
	    if ($@) {
		display_and_log('ERROR', $@);
		delete $config{'up_host'};
	    }
	}

	# schedule optimistically all tests
	schedule_event($ASAP, \&test_ping);
	schedule_event($ASAP, \&test_dl);
	schedule_event($ASAP, \&test_ul);
	schedule_event($ASAP, \&test_breakdown);
    }
}

# --------------------------- VERSION ----------------------------

sub store_version($$) {
    my($vhash, $filename) = @_;
    open(FN, ">$filename") or die "$filename: $!";
    map { print FN "$_=$vhash->{$_}\n"; } sort keys %$vhash;
    close FN;
}

sub load_version($) {
    my($filename) = @_;
    my(%vhash) = ();
    if(open(FN, "<$filename")) {
	while(<FN>) {
	    chomp;
	    $vhash{$1} = $2 if /^([^=]*)=(.*)$/;
	}
	close FN;
    }
    return %vhash;
}

sub version_to_string($) {
    my($vhash) = @_;
    my($version) = "$vhash->{'client'} $vhash->{'version'}";
    $version .= " beta $vhash->{'beta'}" if $vhash->{'beta'};
    $version .= " build $vhash->{'build'}" if $vhash->{'build'};
    $version .= " pour $vhash->{'system'}";
    return $version;
}

sub compare_versions($$) {
    my($vhash1, $vhash2) = @_;
    my($cmp);
    return undef if $vhash1->{'client'} ne $vhash2->{'client'};
    # will become wrong when plgrenouille will run on different systems ?
    return undef if $vhash1->{'system'} ne $vhash2->{'system'};
    $cmp = ($vhash1->{'version'} <=> $vhash2->{'version'});
    return $cmp if $cmp;
    return -1 if $vhash1->{'beta'} and not $vhash2->{'beta'};
    return 1 if not $vhash1->{'beta'} and $vhash2->{'beta'};
    $cmp = ($vhash1->{'beta'} <=> $vhash2->{'beta'});
    return $cmp if $cmp;
    $cmp = ($vhash1->{'build'} <=> $vhash2->{'build'});
    return $cmp;
}

sub display_version() {
    # ASCII art by Donna Shepherd
    print "\n",
    "         @..@\n",
    '        (\--/)               ', version_to_string(\%VERSION), "\n",
    "       (.>__<.)\n",
    "       ^^^  ^^^\n\n";
}

sub check_last_version($) { # EVENT
    my($schedule_time) = shift;
    return unless $vars{'id'};
    
    my(%version);
    eval {
	%version = contact_server("command=get_last_version&id=$vars{'id'}");
    };
    if (not $@) {
        my($check);
	# 0 looks like a better special case value than 255 for my taste
	$version{'beta'} = 0 if $version{'beta'} == 255;
	display_and_log('DISPLAY', "Dernire version disponible : " . version_to_string(\%version));
	$check = compare_versions(\%VERSION, \%version);
	if(not defined $check) {
	    display_and_log('WARNING', "Quelque chose de bizarre est en train d'arriver...");
	} else {
	    if($check < 0) {
		my($message) = ($version{'beta'} and not $VERSION{'beta'}) ?
		    "Une nouvelle version de test de plgrenouille est disponible,\nmettez  jour uniquement si vous voulez tester un logiciel en phase bta...\n" :
			"Une nouvelle version de plgrenouille est disponible,\nil est conseill de procder  une mise  jour...\n";
		if(-t STDOUT or not $preferences{'email_notification'}) {
		    # interactive usage, just report the good news
		    display_and_log('DISPLAY', $message);
		} else {
		    # otherwise, notify by email ?
		    my(%last_notified_version) = load_version($LASTVERSIONFILE);
		    if((not %last_notified_version or compare_versions(\%last_notified_version, \%version)) and 
		       open(MAIL, "|mail -s \"" . version_to_string(\%version) . "\" $preferences{'email'}")) {
			print MAIL $message;
			close MAIL;
			store_version(\%version, $LASTVERSIONFILE);
		    }
		}
	    }
	    display_and_log('DISPLAY', 'Super, votre version est plus rcente que celle de grenouille.com ! :)') if $check > 0;
	}
    }
    schedule_event($schedule_time + jitter(1 * $DAY, -1, 1), \&check_last_version);
}

sub daemonize() {
    my($f) = fork();
    die "Couldn't fork in background" unless defined $f;
    if($f) {
        # parent
        swap_privileges();
        open(PID, ">$PIDFILE") or die "$PIDFILE: $!";
        print PID "$f\n";
        close PID;
        swap_privileges();
        exit(0);
    } else {
        # child
        chdir('/');
        close STDIN;
        open(STDIN, '</dev/null');
        close STDOUT;
        open(STDOUT, '>/dev/null');
        close STDERR;
        open(STDERR, '>/dev/null');
    }
}

sub RELOADING {
    schedule_event($ASAP, \&load_preferences);
    schedule_event($ASAP, \&read_config);
    $SIG{HUP} = \&RELOADING;
}

# --------------------------- MAIN ----------------------------

Getopt::Long::Configure('bundling'); # 'no_ignore_case'
eval {
  GetOptions(\%params,
             'log|l=s', \&set_log_level,
             'verbose|v=s', \&set_verbose_level,
             'configure|setup|c',
             'background|b',
             'version|V',
             'help|h|?');
};
if ($@) {
  print "$@\n";
  usage(1);
}
usage(1) if scalar @ARGV;
usage(0) if $params{'help'};
if($params{'version'}) {
    display_version();
    exit(0);
}

open_log();
init_grenouille();

eval {
    init_vars();
    if($params{'configure'}) {
	ask_preferences();
	print "Vous pouvez maintenant lancer plgrenouille normalement.\n";
	exit(0);
    }
    get_preferences();
    if($params{'background'}) {
        daemonize();
    }

    schedule_event($ASAP, \&open_session);
# doesn't work as I'd like combined with exceptions :(
# any signal guru reading ?
# $SIG{HUP} = \&RELOADING;

    while (1) {
	my($event_time, $event_action) = @{get_next_event()}{'time', 'action'};
	&$event_action($event_time);
    }
};
display_and_log('ERROR', $@) if $@;

END {
    close_log();
    unlink $PIDFILE if defined $PIDFILE;
}
