#!/usr/bin/perl
# Linux Director Daemon - run "perldoc ldirectord" for details 
# THIS IS BETA. checkout version 1.6 for a stable version.
# $Id: ldirectord,v 1.9 2000/06/15 09:07:54 jacob Exp $
#  2000, Jacob Rief <jacob.rief@tis.at>
# with help from: Horms <horms@vergenet.net>
# This is GPL software. You should own a few hundred copies
# of the GPL by now. if not, get one at http://www.fsf.org

=head1 NAME

ldirectord - Linux Director Daemon 

Daemon to monitor remote services and control Linux Virtual Server


=head1 SYNOPSIS

B<ldirectord> I<configuration> [B<-d>] [B<-h>]
B<start>|B<stop>|B<restart>|B<reload>|B<status>


=head1 DESCRIPTION

B<ldirectord> is a daemon to monitor and administer real servers in a
cluster of load balanced virtual servers. B<ldirectord> typically is
started from heartbeat but can also be run from the command line. On
startup B<ldirectord> reads the file B</etc/ha.d/conf/>I<configuration>.
After parsing the file, entries for virtual servers are created on the LVS.
Now at regular intervals the specified real servers are monitored and if
they are considered alive, added to a list for each virtual server. If a
real server fails, it is removed from that list. Only one instance of
B<ldirectord> can be started for each configuration, but more instances of
B<ldirectord> may be started for different configurations. This helps to
group clusters of services.  Normally one would put an entry inside
B</etc/ha.d/haresources>

I<nodename virtual-ip-address ldirectord::configuration>

to start ldirectord from heartbeat.


=head1 OPTIONS

I<configuration>:
This is the name for the configuration as specified in the file
B</etc/ha.d/conf/>I<configuration> 

B<-d> Don't start as daemon. Useful for debugging. 

B<-h> Help. Print user manual of ldirectord. 

B<start> the daemon for the specified configuration.

B<stop> the daemon for the specified configuration. This is the same as sending
a TERM signal the the running daemon.

B<restart> the daemon for the specified configuration. The same as stopping and starting.

B<reload> the configuration file. This is only useful for modifications
inside a virtual server entry. It will have no effect on adding or
removing a virtual server block. This is the same as sending a HUP signal to
the running daemon.

B<status> of the running daemon for the specified configuration.


=head1 SYNTAX 

=head2 Description how to write configuration files

B<virtual = >I<x.y.z.w:p|f>

Defines a virtual service by IP-address and port or firewall-mark.  A
firewall-mark is an integer greater than zero. The configuration of marking
packets is controled using the C<-m> option to B<ipchains>(8).  All real
services and flags for a virtual service must follow this line immediately
and be indentet.

B<timeout = >I<n>

defines the number of second until a real server is declared dead

B<checkinterval = >I<n>

Defines the number of second between server checks.

B<autoreload = >[B<yes>|B<no>]

Defines if <ldirectord> should contineously check the configuration
file for modification. If this is set to 'yes' and the configuration
file changed on disk, the configuration is automatically reloaded.

B<callback = ">I</path/to/callback>B<">

If this directive is defined, B<ldirectord> automatically calls
the executable I</path/to/callback> after the configuration
file has changed on disk. This is useful to update the configuration
file through B<scp> on the other heartbeated host. The first argument
to the callback is the name of the configuration.

This directive might also be used to restart B<ldirectord> automatically
after the configuration file changed on disk. However, if B<autoreload>
is set to yes, the configuration is reloaded anyway.

B<fallback = >I<x.y.z.w:p>

the server onto which a webservice is redirected if all real
servers are down. Typically this would be 127.0.0.1 with
an emergency page.


B<logfile = ">I</path/to/logfile>B<">

an alternative logfile might be specified with this directive.

=head2 These commands must follow a B<virtual> entry and must
be indented (minimum 4 spaces or one tab)

B<real => I<x.y.z.w:p> B<gate>|B<masq>|B<ipip> [I<weight>] [B<">I<request>B<", ">I<receive>B<">]

Defines a real service by IP-address and port. The second argument
defines the forwarding method, must be B<gate>, B<ipip> or B<masq>.
The thrid argument is optional and defines the weight for that real server.
The last two arguments are optional. They define a request-receive pair to 
be used to check if a server is alive. They override the request-receive
pair in the virtual server section. These two strings must be quoted.
If the request string starts with I<http://...> the IP-address of the real
server is overridden, otherwise the IP-address of the real server is used.
This may be used to send a request over a transparent proxy.

=head2 More than one of these entries may be inside a virtual section:

B<service = http>|B<https>|B<none>

The type of service to monitor. None denotes a service that will not be
monitored. If a port is specfied for the service and is 443 the default is
https. If a port is specified and is 80 the default is http. Otherwise the
default is none.

B<request = ">I<uri to requested object>B<">

This object will be requested each checkinterval seconds on each real server.
The string must be inside quotes. Note that this string may be overridden
by an optional per real-server based request-string.

B<receive = ">I<string to compare>B<">

If the requested result contains this I<string to compare>, the real server
is declared alive. The string must be inside quotes. Note that this string may
be overridden by an optional per real-server based receive-string.

B<scheduler = rr>|B<wrr>|B<lc>|B<wlc>

Scheduler to be used for loadbalance.

B<persistent => I<n>

Number of seconds for persistent client connections.

B<protocol = tcp>|B<udp>|B<fwm>

Protocol to be used. If the virtual is specified as an IP address and port
then it must be one of tcp or udp and will default to tcp. If a firewall
mark then the protocol must be fwm, which is the default.


=head1 FILES

B</etc/ha.d/conf/>I<configuration>

B</var/log/ldirectord.log>

B</var/run/ldirectord.>I<configuration>B<.pid>

=head1 SEE ALSO

L<ipvsadm>, L<heartbeat>


=head1 AUTHORS

Jacob Rief <jacob.rief@tis.at>

=cut

# default values
$TIMEOUT = 10;
$CHECKINTERVAL = 10;
if(-f "/sbin/ipvsadm") {
  $IPVSADM="/sbin/ipvsadm";
}
else {
  $IPVSADM="/usr/sbin/ipvsadm";
}
$LDIRLOG="/var/log/ldirectord.log";
$RUNPID="/var/run/ldirectord";
$AUTOCHECK="no";
$CALLBACK;
@VIRTUAL;
@REAL;
@OLDVIRTUAL;
$checksum;
$initializing;

use Getopt::Std;
use LWP::UserAgent;
#use LWP::Parallel::UserAgent;
getopts("dh");

# main code
if ($opt_h) {
	system "/usr/bin/perldoc /etc/ha.d/resource.d/ldirectord";
} else {
	$initializing = 1;
	init();
	ld_setup();
	ld_start();
	$initializing = 0;
	ld_main();
}
system("/bin/rm -f $RUNPID.$CONFIG.pid");
exit 0;


# functions
sub init
{
	# install signal handler
	$SIG{'TERM'} = \&ld_term;
	$SIG{'HUP'} = \&ld_hup;

	if ( !defined $ARGV[0] || !defined $ARGV[1] || ($ARGV[1] ne "start" && $ARGV[1] ne "stop"
	     && $ARGV[1] ne "status" && $ARGV[1] ne "restart" && $ARGV[1] ne "reload") ) {
	 	init_error("Usage ldirectord configfile \{start|stop|restart|reload|status\}\nType ldirectord -h for more information");
	} else {
		$CONFIG = $ARGV[0];
		$CMD = $ARGV[1];
		my $oldpid;
		if (open(FILE, "<$RUNPID.$CONFIG.pid")) {
			$_ = <FILE>;
			chomp;
			my $tmppid = $_;
			close(FILE);
			# Check to make sure this isn't a stale pid file
			if (open(FILE, "</proc/$tmppid/cmdline")) {
				$_ = <FILE>;
				if(/ldirectord/) {
					$oldpid = $tmppid;
				}
				close(FILE);
			}
		}
		if (defined $oldpid) {
			# Kill old daemon
			if ($CMD eq "stop") {
				kill 15, $oldpid;
				exit 0;
			} elsif ($CMD eq "restart") {
				kill 15, $oldpid;
				while (-f "$RUNPID.$CONFIG.pid") {
					# wait until old pid file is removed
				}
			} elsif ($CMD eq "reload") {
				kill 1, $oldpid;
				exit 0;
			} elsif ($CMD eq "status") {
				print "ldirectord for $CONFIG is running with pid: $oldpid\n";
				exit 0;
			} else {
				init_error("ldirectord for $CONFIG is already running with pid: $oldpid");
			}
		} else {
			if ($CMD eq "status") {
				print "ldirectord is not running for $CONFIG\n";
				exit 0;
			} elsif ($CMD ne "start") {
				init_error("ldirectord is not running for $CONFIG");
			}
		}
		read_config();
		undef @OLDVIRTUAL;
	}

	# Run as daemon
	if (!defined $opt_d) {
		if ($pid = fork()) {
			# the parent goes away
			open(FILE, ">$RUNPID.$CONFIG.pid") || init_error("Can not open $RUNPID.$CONFIG.pid");
			print FILE "$pid\n";
			close(FILE);
			exit 0;
		} elsif (!defined $pid) {
			init_error("ldirector could not fork: $!");
		}
	}
	open(LOGFILE, ">>$LDIRLOG");
	my $now = localtime()."|$CONFIG";
	print LOGFILE "[$now] Starting Linux Director Daemon\n";
	close(LOGFILE);
}


sub init_error
{
	my $msg = shift;
	chomp($msg);
	if (defined $opt_d) {
		open(LOGFILE, ">>$LDIRLOG");
		print LOGFILE "$msg\n";
		close(LOGFILE);
	} else {
		print STDERR "$msg\n";
	}
	exit 1;
}


sub ld_term
{
	ld_stop();
	open(LOGFILE, ">>$LDIRLOG");
	my $now = localtime()."|$CONFIG";
	print LOGFILE "[$now] Linux Director Daemon terminated\n";
	close(LOGFILE);
	&system_wrapper("/bin/rm -f $RUNPID.$CONFIG.pid");
	exit 0;
}


sub ld_hup
{
	open(LOGFILE, ">>$LDIRLOG");
	my $now = localtime()."|$CONFIG";
	print LOGFILE "[$now] Reloading Linux Director Daemon config\n";
	close(LOGFILE);
	@OLDVIRTUAL = @VIRTUAL;
	eval {
		read_config();
		ld_setup();
		ld_start();
	};
	if ($@) {
		@VIRTUAL = @OLDVIRTUAL;
	}
	undef @OLDVIRTUAL;
}


sub read_config
{
	undef @VIRTUAL;
	undef $CALLBACK;
	undef $checksum;
	open(CFGFILE, "</etc/ha.d/conf/$CONFIG") || config_error(0, "can not open file /etc/ha.d/conf/$CONFIG");
	my $line = 0;
	while(<CFGFILE>) {
		$line++;
		if ($_ =~ /^virtual\s*=\s*(.*)/) {
			$1 =~ /(\d+\.\d+\.\d+\.\d+:\d+|\d+)/
			    or config_error($line, "invalid address for virtual server");
			my (%vsrv, @rsrv);
			$vsrv{server} = $1;
			if ($vsrv{server} =~ /(\d+\.\d+\.\d+\.\d+):(\d+)/) {
			        $vsrv{protocol} = "tcp";
				if ($2 eq "443") {
					$vsrv{service} = "https";
				} elsif ($2 eq "80") {
					$vsrv{service} = "http";
				} else {
					$vsrv{service} = "none";
				}
			} else {
			        $vsrv{protocol} = "fwm";
				$vsrv{service} = "none";
			}
			$vsrv{real} = \@rsrv;
			$vsrv{status} = 0;
			$vsrv{scheduler} = "wrr";
			$vsrv{request} = "/";
			$vsrv{receive} = "";
			push(@VIRTUAL, \%vsrv);
			while(<CFGFILE>) {
				$line++;
				$_ =~ s/\t/    /g;
				last if !($_ =~ /^ {4,}(.*)/);
				my $rcmd = $1;
				next if ($rcmd =~ /^#/);
				if ($rcmd =~ /^real\s*=\s*(.*)/) {
					$1 =~ /(\d+\.\d+\.\d+\.\d+:\d+)\s+(.*)/ 
					    or config_error($line, "invalid address for real server");
					my $rmt = $1;
					$2 =~ /(\w+)(.*)/ && ($1 eq "gate" || $1 eq "masq" || $1 eq "ipip")
					    or config_error($line, "forward method must be gate, masq or ipip");
					my $fwd = $1;
					if ($2 =~ /\s+(\d+)\s+(.*)/) {
						my $weight = $1;
						if ($2 =~ /\"(.*)\",\s*\"(.*)\"/) {
							push(@rsrv, {"server"=>$rmt, "forward"=>$fwd, "weight"=>$weight, "request"=>$1, "receive"=>$2});
						} else {
							push(@rsrv, {"server"=>$rmt, "forward"=>$fwd, "weight"=>$weight});
						}
					} elsif ($2 =~ /\s+\"(.*)\",\s*\"(.*)\"/) {
						push(@rsrv, {"server"=>$rmt, "forward"=>$fwd, "request"=>$1, "receive"=>$2});
					} else {
						push(@rsrv, {"server"=>$rmt, "forward"=>$fwd});
					}
					my $realsrv=0;
					foreach $r (@REAL){
						if($r->{"real"} eq $vsrv{protocol}.":".$rmt){
							my $ref=$r->{"virtual"};
							push(@$ref, $vsrv{"protocol"}.":".$vsrv{"server"});
							$realsrv=1;
							last;
						}
					}
					if($realsrv==0){
						push(@REAL, { "real"=>$vsrv{protocol}.":".$rmt, 
                                                              "virtual"=>[ $vsrv{protocol}.":".$vsrv{"server"} ] });
					}
				} elsif ($rcmd =~ /^request\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "no request string specified");
					$vsrv{request} = $1;
				} elsif ($rcmd =~ /^receive\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "invalid receive string");
					$vsrv{receive} = $1;
				} elsif ($rcmd =~ /^load\s*=\s*\"(.*)\"/) {
					$1 =~ /(\w+)/ or config_error($line, "invalid string for load testing");
					$vsrv{load} = $1;
				} elsif ($rcmd =~ /^scheduler\s*=\s*(.*)/) {
					lc($1);
					$1 =~ /(\w+)/ && ($1 eq "rr" || $1 eq "wrr" || $1 eq "lc" || $1 eq "wlc") 
					    or config_error($line, "scheduler must be rr, wrr, lc or wlc");
					$vsrv{scheduler} = $1;
				} elsif ($rcmd =~ /^persistent\s*=\s*(.*)/) {
					$1 =~ /(\d+)/ or config_error($line, "invalid persistent timeout");
					$vsrv{persistent} = $1;
				} elsif ($rcmd =~ /^protocol\s*=\s*(.*)/) {
					lc($1);
					if ( $1 =~ /(\w+)/ ) {
						if ( $vsrv{protocol} eq "fwm" ) {
							if ($1 eq "fwm" ) {
								; #Do nothing, it is already set
							} else {
								config_error($line, "protocol must be fwm if the virtual service is a fwmark (a number)");
							}
						} else {    # tcp or udp
							if ($1 eq "tcp" || $1 eq "udp") {
								$vsrv{protocol} = $1;
							} else {
								config_error($line, "protocol must be tcp or udp if the virtual service is an address and port");
							}
						}
					} else {
						config_error($line, "invalid protocol");
					}
				} elsif ($rcmd =~ /^service\s*=\s*(.*)/) {
					lc($1);
					$1 =~ /(\w+)/ && ($1 eq "http" || $1 eq "https" || $1 eq "none")
					    or config_error($line, "service must be http, https or none");
					$vsrv{service} = $1;
				} elsif ($rcmd =~ /^sitename\s*=\s*(.*)/) {
					$1 =~ /(\w+)/ or config_error($line, "invalid sitename");
					$vsrv{sitename} = $1;
				} else {
					config_error($line, "Unknown command $_");
				}
			}
		}
		next if ($_ =~ /^\s*$/ || $_ =~ /^\s*#/);
		if ($_ =~ /^timeout\s*=\s*(.*)/) {
			$1 =~ /(\d+)/ && $1 or config_error($line, "invalid timeout value");
			$TIMEOUT = $1;
		} elsif ($_ =~ /^checkinterval\s*=\s*(.*)/) {
			$1 =~ /(\d+)/ && $1 or config_error($line, "invalid checkinterval value");
			$CHECKINTERVAL = $1;
		} elsif ($_ =~ /^fallback\s*=\s*(.*)/) {
			my $tmp = $1;
			($tmp =~ /(\d+\.\d+\.\d+\.\d+:\d+)/ || $tmp =~ /(\d+\.\d+\.\d+\.\d+)/) && $1
			    or config_error($line, "invalid address for fallback server");
			$FALLBACK = $1;
		} elsif ($_ =~ /^autoreload\s*=\s*(.*)/) {
			($1 eq "yes" || $1 eq "no")
			    or config_error($line, "autoreload must be 'yes' or 'no'");
			$AUTOCHECK = $1;
		} elsif ($_ =~ /^callback\s*=\s*\"(.*)\"/) {
			$CALLBACK = $1;
		} elsif ($_ =~ /^logfile\s*=\s*\"(.*)\"/) {
			if (open(LOGFILE, ">>$1")) {
				print LOGFILE "Reading file conf/$CONFIG\n";
				close(LOGFILE);
				$LDIRLOG = $1;
			} else {
				config_error($line, "unable to open logfile: $1");
			}
		} else {
			config_error($line, "Unknown command $_");
		}
	}
	close(CFGFILE);
	return(0);
}


sub config_error
{
	my ($line, $msg) = @_;
	if (defined $opt_d || $initializing==1) {
		if ($line>0) {
			print STDERR "Error reading file conf/$CONFIG at line $line: $msg\n";
		} else {
			print STDERR "Error: $msg\n";
		}
	} else {
		open(LOGFILE, ">>$LDIRLOG");
		if ($line>0) {
			print LOGFILE "Error reading file conf/$CONFIG at line $line: $msg\n";
		} else {
			print LOGFILE "Error: $msg\n";
		}
		close(LOGFILE);
	}
	if ($initializing) {
		&system_wrapper("/bin/rm -f $RUNPID.$CONFIG.pid");
		exit 2;
	} else {
		die;
	}
}


sub ld_setup
{
	foreach $v (@VIRTUAL) {
		if ($$v{protocol} eq "tcp") {
			$$v{proto} = "-t";
		} elsif ($$v{protocol} eq "udp") {
			$$v{proto} = "-u";
		} elsif ($$v{protocol} eq "fwm") {
			$$v{proto} = "-f";
		}
		$$v{flags} = "$$v{proto} $$v{server} ";
		$$v{flags} .= "-s $$v{scheduler} " if defined ($$v{scheduler});
		$$v{flags} .= "-p $$v{persistent} " if defined ($$v{persistent});
		my $real = $$v{real};
		foreach $r (@$real) {
			if ($$r{forward} eq "masq") {
				$$r{forw} = "-m";
			} elsif ($$r{forward} eq "gate") {
				$$r{forw} = "-g";
			} elsif ($$r{forward} eq "ipip") {
				$$r{forw} = "-i";
			} else {
				$$r{forw} = " ";
			}
			if (defined $$r{weight}) {
				 $$r{wght} = "-w $$r{weight}";
			} else {
				 $$r{wght} = " ";
			}
			$$r{status} = -1;
        		if (defined $$r{request} && defined $$r{receive}) {
				my $uri = $$r{request};
				$uri =~ s/^\///g;
				if ($$r{request} =~ /$$v{service}:\/\//) {
					$$r{url} = "$$r{request}";
				} else {
					$$r{url} = "$$v{service}:\/\/$$r{server}\/$uri";
				}
			} else {
				my $uri = $$v{request};
				$uri =~ s/^\///g;
				$$r{url} = "$$v{service}:\/\/$$r{server}\/$uri";
                		$$r{receive} = $$v{receive};
			}
		}
		$$v{status} = -1;
	}
}


sub ld_start
{
	open(LOGFILE, ">>$LDIRLOG");
	# read status of current ipvsadm -L -n
	open(IPVS, "$IPVSADM -L -n |");
	$_ = <IPVS>; $_ = <IPVS>; $_ = <IPVS>;
	my %oldsrv;
	my $real_service;
	while (<IPVS>) {
		if ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)/) {
			my $prot = lc $1;
			$real_service = "$2 " . lc $1;
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4};
		} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)/) {
			my $prot = lc $1;
			$real_service = "$2 " . lc $1;
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3};
		} else {
			next;
		}
		while(<IPVS>) {
			last unless $_ =~ / ->\s+(\d+\.\d+\.\d+\.\d+\:\d+)\s+(\w+)\s+(\d+)/;
			if ($2 eq "Route") {
				$fwd = "gate";
			} elsif ($2 eq "Tunnel") {
				$fwd = "ipip";
			} elsif ($2 eq "Masq") {
				$fwd = "masq";
			}
			$oldsrv{"$real_service"}->{"real"}->{"$1"} = {"forward"=>$fwd, "weight"=>$3};
		}
		redo;
	}
	close(IPVS);

	# modify service, if changed 
	my $now = localtime()."|$CONFIG";
	foreach $nv (@VIRTUAL) {
		my $nreal = $$nv{real};
		$$nv{status} = 0;
		if (exists($oldsrv{"$$nv{server} $$nv{protocol}"})) {
			# service exists, modify it
			&system_wrapper("$IPVSADM -E $$nv{flags}");
			print LOGFILE "[$now] Changing virtual server: $$nv{server}\n";
			my $ov = $oldsrv{"$$nv{server} $$nv{protocol}"};
			my $or = $$ov{real};
			foreach $nr (@$nreal) {
				if (exists($$or{"$$nr{server}"})) {
					&system_wrapper("$IPVSADM -e $$nv{proto} $$nv{server} -R $$nr{server} $$nr{forw} $$nr{wght}");
					$$nr{status} = 1;
					$$nv{status}++;
					print LOGFILE "[$now] Changing real server: $$nr{server} ($$nv{status}*$$nv{server})\n";
					delete($$or{"$$nr{server}"});
				} else {
					$$nr{status} = 0;
				}		
			}
			# remove remaining entries for real servers
			foreach $k (keys %$or) {
				&system_wrapper("$IPVSADM -d $$nv{proto} $$nv{server} -R $k");
				print LOGFILE "[$now] Removing real server: $$nr{server} ($$nv{status}*$$nv{server})\n";
			}
			delete $oldsrv{"$$nv{server} $$nv{protocol}"};
		} else {
			# no such service, create a new one
			&system_wrapper("$IPVSADM -A $$nv{flags}");
			foreach $nr (@$nreal) {
				$$nr{status} = 0;
			}
			print LOGFILE "[$now] Adding virtual server: $$nv{server}\n";
		}

		if (defined $FALLBACK && $$nv{status}==0) {
			# turn on fallback service
			&system_wrapper("$IPVSADM -a $$nv{proto} $$nv{server} -R $FALLBACK");
			print LOGFILE "[$now] Starting fallback server for: $$nv{server}\n";
		}
	}

	# remove remaining entries for virtual servers
	foreach $nv (@OLDVIRTUAL) {
		if (exists($oldsrv{"$$nv{server} $$nv{protocol}"})) {
			# service still exists, remove it
			&system_wrapper("$IPVSADM -D $$nv{proto} $$nv{server}");
			print LOGFILE "[$now] Removing virtual server: $$nv{server}\n";
		}
	}
	close(LOGFILE);
}


sub ld_stop
{
	open(LOGFILE, ">>$LDIRLOG");
	my $now = localtime()."|$CONFIG";
	foreach $v (@VIRTUAL) {
		my $real = $$v{real};
		foreach $r (@$real) {
			if ($$r{status}>0) {
				&system_wrapper("$IPVSADM -d $$v{proto} $$v{server} -R $$r{server}");
				$$r{status} = 0;
				$$v{status}--;
				print LOGFILE "[$now] Removing real server: $$r{server} ($$v{status}*$$v{server})\n";
			}
		}
		&system_wrapper("$IPVSADM -D $$v{proto} $$v{server}");
		print LOGFILE "[$now] Removing virtual server: $$v{server}\n";
	}
	close(LOGFILE);
}


sub ld_main
{
	# Main failover checking code
	while (1) {
		open(LOGFILE, ">>$LDIRLOG");
		my @real_checked;
		foreach $v (@VIRTUAL) {
			my $real = $$v{real};
			# unfortunately LWP::Paralell::UserAgent
			# does not work right now for https and
			# has some major problems with http

			# my $ua = new LWP::Parallel::UserAgent;
			# $ua->redirect(0);
			# $ua->max_hosts($#$real+1);
			# $ua->max_req($#$real+1);
			foreach $r (@$real) {
				unless(grep(/^$$v{protocol}:$$r{server}$/, @real_checked)){
					if ($$v{service} eq "http") {
						check_http($v, $r);
						# my $req = new HTTP::Request(GET=>"$$r{url}");
						# $ua->register($req, \&http_received);
					} elsif ($$v{service} eq "https") {
						check_http($v, $r);
					} else {
						check_server($v, $r);
					}
					push(@real_checked, "$$v{protocol}:$$r{server}");
				}
			}
			# $ua->wait($TIMEOUT);
		}
		check_cfgfile();
		close(LOGFILE);
		sleep $CHECKINTERVAL;
	}
}


sub http_received
# callbackfunction for Parallel::UserAgent
{
	my ($content, $respone, $proto) = @_;
	my $req = $$respone{_request};
	my $url = $$req{_uri};
	if ($url =~ /(http\w?):\/\/([^\/:]+)(.*)/) {
		my ($p, $s, $u) = ($1, $2, $3);
		$url = "$p://$s:80$u" if ($p eq "http" && $u =~ /^\//);
		$url = "$p://$s:443$u" if ($p eq "https" && $u =~ /^\//);
	}
	foreach $v (@VIRTUAL) {
		my $real = $$v{real};
		foreach $r (@$real) {
			if ($url eq $$r{url}) {
				my $receive_string = $$r{receive};
				if (!($receive_string =~ /.+/) || $content =~ /$receive_string/) {
					service_set($v, $r, "up");
				} else {
					service_set($v, $r, "down");
				}
			}
		}
	}
	return C_ENDCON;
}


sub check_http
# Do the complete servercheck here
{
	my ($v, $r) = @_;
	my $ua = new LWP::UserAgent;
	$ua->agent("LinuxDirector/0.1".$ua->agent);
	$ua->timeout($TIMEOUT);
	my $req = new HTTP::Request(GET=>"$$r{url}");
	my $res = $ua->request($req);
	if ($res->is_success && (!($receive_string =~ /.+/) || $res->content =~ /$receive_string/)) {
		service_set($v, $r, "up");
	} else {
		service_set($v, $r, "down");
	}
}


sub check_server
# dummy function for unknown services
{
	my ($v, $r) = @_;
	service_set($v, $r, "up");
}


sub service_set()
{
	my ($v, $r, $state) = @_;

	my ($real, $virtual, $virt);
	foreach $real (@REAL) {
		if($real->{"real"} eq "$$v{protocol}:$$r{server}"){
			$virtual = $real->{"virtual"};
			last;
		}
	}
	return unless(defined($virtual));
	return if($$r{status}!=0 and $state=~/up/i);
	return if($$r{status}!=1 and $state=~/down/i);
	foreach $v (@VIRTUAL){
		if(grep(/^$$v{protocol}:$$v{server}$/, @$virtual)){
			if($state=~/up/i){
				$$r{status}=0;
				_service_up($v, $r);
			}
			elsif($state=~/down/i){
				$$r{status}=1;
				_service_down($v, $r);
			}
		}
	}
}

      
sub _service_up
{
	my ($v, $r) = @_;
	if ($$r{status}==0) {
		&system_wrapper("$IPVSADM -a $$v{proto} $$v{server} -R $$r{server} $$r{forw} $$r{wght}");
		$$r{status} = 1;
		$$v{status}++;
		my $now = localtime()."|$CONFIG";
		print LOGFILE "[$now] Adding real server: $$r{server} ($$v{status}*$$v{server})\n";
		if ($$v{status}==1 && defined $FALLBACK) {
			# turn off fallback service
			&system_wrapper("$IPVSADM -d $$v{proto} $$v{server} -R $FALLBACK");
			print LOGFILE "[$now] Turning off fallback server for: $$v{server}\n";
		}
	}
}


sub _service_down
{
	my ($v, $r) = @_;
	if ($$r{status}==1) {
		&system_wrapper("$IPVSADM -d $$v{proto} $$v{server} -R $$r{server}");
		$$r{status} = 0;
		$$v{status}--;
		my $now = localtime()."|$CONFIG";
		print LOGFILE "[$now] Removing real server: $$r{server} ($$v{status}*$$v{server})\n";
		if ($$v{status}==0 && defined $FALLBACK) {
			# turn on fallback service
			&system_wrapper("$IPVSADM -a $$v{proto} $$v{server} -R $FALLBACK");
			print LOGFILE "[$now] Starting fallback server for: $$v{server}\n";
		}
	}
}


sub check_cfgfile
{
	return unless ($AUTOCHECK eq "yes" || defined $CALLBACK);
	my $filename = shift;
	my $chs = 0;
	my $lctr = 0;
	open(CFGFILE, "</etc/ha.d/conf/$CONFIG") || config_error(0, "can not open file /etc/ha.d/conf/$CONFIG");
	while (<CFGFILE>) {
		$lctr++;
		$chs += (4*($lctr%3)+3)*unpack("%32C*", $_);
	}
	close(CFGFILE);
	if (defined $checksum && $chs!=$checksum) {
		my $now = localtime()."|$CONFIG";
		print LOGFILE "[$now] Configuration file has changed on disk\n";
		if ($AUTOCHECK eq "yes") {
			print LOGFILE "[$now] Rereading Linux Director Daemon config\n";
			@OLDVIRTUAL = @VIRTUAL;
			eval {
				read_config();
				ld_setup();
				ld_start();
			};
			if ($@) {
				@VIRTUAL = @OLDVIRTUAL;
			}
			undef @OLDVIRTUAL;
		}
		if (-x $CALLBACK) {
			my $rc = system("$CALLBACK $CONFIG");
			print LOGFILE "[$now] Callback: $CALLBACK returned code: $rc\n";
		}
	}
	$checksum = $chs;
}


# system_wrapper
# Wrapper arround system command to log errors
# pre: LIST: arguments to pass to system()
# post: system is called and if it returns non-zero a failure message is logged
# return: none
#
# Added by Horms <horms@vergenet.net>, 11th January 2000

sub system_wrapper
{
	my (@args)=(@_);

	my $now = localtime() . "|$CONFIG";
	system(@_) == 0 or print LOGFILE  "[$now] system(@args) failed\n"
}

