#!/usr/bin/perl
#
# Linux Director Daemon - run "perldoc ldirectord" for details
# $Id: ldirectord,v 1.26 2001/02/07 12:33:32 jacob Exp $
#  2000, Jacob Rief <jacob.rief@tiscover.com>
# 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 indented.

B<checktimeout = >I<n>

Defines the number of second until a real server is declared dead. Default
is 5 seconds. If defined in virtual server section then the global value
is overridden.

B<connecttimeout = >I<n>

Not used.

B<negotiatetimeout = >I<n>

Defines the number of seconds to wait for TCP/IP timeouts. Default is 
defined by the operating system. If defined in virtual server section
then the global value is overridden.

B<checkinterval = >I<n>

Defines the number of second between server checks. Default is 10 seconds.

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

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

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.

This directive may also appear within a virtual server, in which 
case it will overide the global fallback server, if set.


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

an alternative logfile might be specified with this directive.


B<execute = ">I<configuration>B<">

Use this directive to start an instance of ldirectord for
the named I<configuration>.


B<foreground>

If this directive is specified, the daemon does not go into background mode.
This is useful to run B<ldirectord> for instance from daemontools.


=head2 Section virtual

The following commands must follow a B<virtual> entry and must be indented
with a minimum of 4 spaces or one tab.

B<real => I<w.x.y.z[-a.b.c.d]: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. Optionally a range of IP
addresses may be given, in which case each IP address in the range will be
treated as a real server using the given 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<checktype = >I<negotiate>|I<connect>|I<N>|I<off>

Type of check to perform. Negotiate sends a request and matches a receive
string. Connect only attemts to make a TCP/IP connection, thus the the
request and receive strings may be omitted.  Type of check to perform.
Negotiate means to send request and expect receive strings. Connect means
raw tcp/ip connection, here the request and receive string can be omitted.
If checktype is a number then negotiate and connect is combined so that
after each N connect attempts one negotiate attempt is performed. This is
useful to check often if a service answers and in much longer intervalls a
negotiating check is done.  Off means no checking will take place and no
real or fallback servers will be activated. Default is I<negotiate>.

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

The type of service to monitor. None denotes a service that will not be
monitored. If the port specfied for the virtual server is 80 the default
service is B<http>.  If the port specified is 443 the default service is
B<https>.  If the port specified is 21 the default service is B<ftp>.
Otherwise the default service is B<none>.

B<checkport = >I<n>

Number of port to monitor. Sometimes check port differs from service port.
Default is port specified for the real server.

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<login = ">I<username>B<">

Username to use to login to FTP server. Default is anonymous.


B<passwd = ">I<password>B<">

Password to use to login to FTP server. Default is ldirectord\@<hostname>,
where hostname is the environment variable HOSTNAME evaluated at run time.


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

Scheduler to be used for loadbalance. Default is "wrr".

B<persistent => I<n>

Number of seconds for persistent client connections.

B<netmask => I<w.x.y.z>

Netmask to be used for granularity of 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/ldirectord.cf>

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

B</var/log/ldirectord.log>

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

B</etc/>I<services>

=head1 SEE ALSO

L<ipvsadm>, L<heartbeat>


=head1 AUTHORS

Jacob Rief <jacob.rief@tiscover.com>

Horms <horms@vergenet.net>, <horms@valinux.com>

Skliarouk Peter <skliaroukp@bigfoot.com>

=cut

# default values
$CHECKTIMEOUT = 5;
$CONNECTTIMEOUT = 0;
$NEGOTIATETIMEOUT = 0;
$CHECKINTERVAL = 10;
$LDIRECTORD="/usr/sbin/ldirectord"; # path onto myself
$LDIRLOG="/var/log/ldirectord.log";
$RUNPID="/var/run/ldirectord";
$AUTOCHECK="no";
$CALLBACK;
$FOREGROUND;
@VIRTUAL;
@OLDVIRTUAL;
@REAL;
%LD_INSTANCE;
$LD_TERM_CALLED=0;
$checksum;
$stattime;
$initializing;

use Getopt::Std;
use English;
#use Time::HiRes qw( gettimeofday tv_interval );
use Socket;
use Sys::Hostname;
#use LWP::Parallel::UserAgent;
use POSIX qw(setsid);

# command line options
getopts("dh");

$DEBUG = 3 if (defined $opt_d);
if ($DEBUG>0 and -f "./ipvsadm") {
	$IPVSADM="./ipvsadm";
} else {
	if (-x "/sbin/ipvsadm") {
		$IPVSADM="/sbin/ipvsadm";
	} elsif (-x "/usr/sbin/ipvsadm") {
		$IPVSADM="/usr/sbin/ipvsadm";
	} else {
		die "Can not find ipvsadm";
	}
}

# main code
if ($opt_h) {
	&system_wrapper("/usr/bin/perldoc $LDIRECTORD");
} else {
	$initializing = 1;
	init();
	ld_setup();
	ld_start();
	ld_cmd_children("start", %LD_INSTANCE);
	$initializing = 0;
	ld_main();
}
&ld_rm_file("$RUNPID.$CFGNAME.pid");
&ld_exit(0, "Reached end of \"main\"");


# functions
sub init
{
	# install signal handlers (this covers TERM)
	my $i;
	for $i (keys %SIG) {
		$SIG{"$i"} = \&ld_term;
	}

	# except CHLD, USR1, USR2 and __WARN__
	$SIG{'CHLD'} = "DEFAULT";
	$SIG{'USR1'} = "DEFAULT";
	$SIG{'USR2'} = "DEFAULT";
	$SIG{'__WARN__'} = "DEFAULT";

	# HUP is actually used
	$SIG{'HUP'} = \&ld_hup;

	# search for the correct configuration file
	if ( !defined $ARGV[0] ) {
	 	init_error("Usage ldirectord [configfile] \{start|stop|restart|reload|status\}\nRun ldirectord -h for more information");
	}
	if ( defined $ARGV[0] && defined $ARGV[1] ) {
		$CONFIG = $ARGV[0];
		if ($CONFIG =~ /([^\/]+)$/) {
			$CFGNAME = $1;
		}
		$CMD = $ARGV[1];
	} elsif ( defined $ARGV[0] ) {
		$CONFIG = "ldirectord.cf";
		$CFGNAME = "ldirectord";
		$CMD = $ARGV[0];
	}
	if ( -f "/etc/ha.d/$CONFIG" ) {
		$CONFIG = "/etc/ha.d/$CONFIG";
	} elsif ( -f "/etc/ha.d/conf/$CONFIG" ) {
		$CONFIG = "/etc/ha.d/conf/$CONFIG";
	} elsif ( ! -f "$CONFIG" ) {
		init_error("Config file $CONFIG not found");
	}
	if ( $CMD ne "start" && $CMD ne "stop" && $CMD ne "status" && $CMD ne "restart" && $CMD ne "reload") {
	 	init_error("Usage ldirectord [configfile] \{start|stop|restart|reload|status\}\nType ldirectord -h for more information");
	}
	my $oldpid;
	if (open(FILE, "<$RUNPID.$CFGNAME.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;
			ld_exit(0, "Exiting from ldirectord stop");
		} elsif ($CMD eq "restart") {
			kill 15, $oldpid;
			while (-f "$RUNPID.$CFGNAME.pid") {
				# wait until old pid file is removed
			}
		} elsif ($CMD eq "reload") {
			kill 1, $oldpid;
			ld_exit(0, "Exiting from ldirectord reload");
		} elsif ($CMD eq "status") {
			print "ldirectord for $CONFIG is running with pid: $oldpid\n";
			ld_cmd_children("status", %LD_INSTANCE);
			ld_exit(0, "Exiting from ldirectord status");
		} 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";
		} elsif ($CMD ne "start") {
			init_error("ldirectord is not running for $CONFIG");
		}
	}
	read_config();
	undef @OLDVIRTUAL;

	# Run as daemon
	if (!defined $opt_d) {
		&ld_daemon();
		open(FILE, ">$RUNPID.$CFGNAME.pid") || init_error("Can not open $RUNPID.$CFGNAME.pid");
		print FILE "$$\n";
		close(FILE);
	}
	&ld_log("Starting Linux Director Daemon");
}


sub init_error
{
	my $msg = shift;
	chomp($msg);
	if (defined $opt_d) {
		&ld_log("$msg");
	} else {
		print STDERR "$msg\n";
	}
	ld_exit(1, "Initialisation Error");
}


# ld_term
# If we get a sinal then log it and quit
sub ld_term
{
        my ($signal) = (@_);
	print STDERR "ldirectord $CFGNAME received signal: $signal\n";
	if ($LD_TERM_CALLED){ 
		$SIG{'__DIE__'} = "IGNORE";
		$SIG{"$signal"} = "IGNORE";
		die("Exit Handler Repeatedly Called\n"); 
	}
	$LD_TERM_CALLED = 1;

	ld_cmd_children("stop", %LD_INSTANCE);
	ld_stop();
	&ld_log("Linux Director Daemon terminated on signal: $signal");
	&ld_rm_file("$RUNPID.$CFGNAME.pid");
	&ld_exit(0, "Linux Director Daemon terminated on signal: $signal");
}


sub ld_hup
{
        my ($signal) = (@_);
	&ld_log("Reloading Linux Director Daemon config on signal: $signal");
	reread_config();
}


sub reread_config
{
	@OLDVIRTUAL = @VIRTUAL;
	my %OLD_INSTANCE = %LD_INSTANCE;
	eval {
		read_config();
		my %NEW_INSTANCE = %LD_INSTANCE;
		ld_setup();
		ld_start();
		my $child;
		foreach $child (keys %OLD_INSTANCE) {
			if (exists $NEW_INSTANCE{$child}) {
				delete $OLD_INSTANCE{$child};
				delete $NEW_INSTANCE{$child};
				if (system("$LDIRECTORD $child reload")) {
					system("$LDIRECTORD $child start");
				}
			}
		}
		ld_cmd_children("stop", %OLD_INSTANCE);
		ld_cmd_children("start", %NEW_INSTANCE);
	};
	if ($@) {
		@VIRTUAL = @OLDVIRTUAL;
		%LD_INSTANCE = %OLD_INSTANCE;
	}
	undef @OLDVIRTUAL;
}


sub read_config
{
	undef @VIRTUAL;
	undef $CALLBACK;
	undef $FOREGROUND;
	undef $checksum;
	$stattime = 0;
	undef %LD_INSTANCE;
	open(CFGFILE, "<$CONFIG") || config_error(0, "can not open file $CONFIG");
	my $line = 0;
	while(<CFGFILE>) {
		$line++;
		outer_loop:
		if ($_ =~ /^virtual\s*=\s*(.*)/) {
			$1 =~ /(((\d+\.\d+\.\d+\.\d+):(\d+))|(\d+))/
			    or config_error($line, "invalid address for virtual server");
			my (%vsrv, @rsrv);
			if (defined($2)) {
			        $vsrv{server} = $3;
			        $vsrv{port} = $4;
				$vsrv{checktype} = "connect";
			        $vsrv{protocol} = "tcp";
				( $vsrv{port}>0 && $vsrv{port}<65536 ) or config_error($line, "port number must be in range 1..65536");
				if ($vsrv{port} eq "80") {
					$vsrv{service} = "http";
				} elsif ($vsrv{port} eq "443") {
					$vsrv{service} = "https";
				} elsif ($vsrv{port} eq "21") {
					$vsrv{service} = "ftp";
				} else {
					$vsrv{service} = "none";
				}
			} else {
			        $vsrv{fwm} = $5;
				$vsrv{checktype} = "negotiate";
			        $vsrv{protocol} = "fwm";
				$vsrv{service} = "none";
				$vsrv{port} = "0";
			}
			$vsrv{real} = \@rsrv;
			$vsrv{status} = 0;
			$vsrv{scheduler} = "wrr";
			$vsrv{request} = "/";
			$vsrv{receive} = "";
			$vsrv{login} = "anonymous";
			$vsrv{passwd} = "ldirectord\@$ENV{HOSTNAME}";
			$vsrv{checktimeout} = 0;
			$vsrv{connecttimeout} = 0;
			$vsrv{negotiatetimeout} = 0;
			$vsrv{num_connects} = 0;
			push(@VIRTUAL, \%vsrv);
			while(<CFGFILE>) {
				$line++;
				$_ =~ s/\t/    /g;
				unless ($_ =~ /^ {4,}(.*)/) {
				  #Arggh a goto :(
				  goto outer_loop;
				}
				my $rcmd = $1;
				next if ($rcmd =~ /^#/);
				if ($rcmd =~ /^real\s*=\s*(.*)/) {
					$1 =~ /(\d+\.\d+\.\d+\.\d+)(-(\d+\.\d+\.\d+\.\d+))?:(\d+)\s+(.*)/ 
					    or config_error($line, "invalid address for real server");
					if ( defined ($2) ) {
						add_real_server_range($line, \%vsrv, \@rsrv, $1, $3, $4, $5);
					} else {
						add_real_server($line, \%vsrv, \@rsrv, $1, $4, $5);
					}
				} elsif ($rcmd =~ /^request\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "no request string specified");
					$vsrv{request} = $1;
					unless($vsrv{request}=~/^\//){
						$vsrv{request} = "/" . $vsrv{request};
					}

				} elsif ($rcmd =~ /^receive\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "invalid receive string");
					$vsrv{receive} = $1;
				} elsif ($rcmd =~ /^checktype\s*=\s*(.*)/){
                                        lc($1);
					if ($1 =~ /(\d+)/ && $1>=0) {
						$vsrv{num_connects} = $1;
						$vsrv{checktype} = "combined";
					} elsif ( $1 =~ /(\w+)/ && ($1 eq "connect" || $1 eq "negotiate" || $1 eq "off") ) {
						$vsrv{checktype} = $1;
					} else {
						config_error($line, "checktype must be connect, negotiate, off or a positive number");
					}
				} elsif ($rcmd =~ /^checktimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or config_error($line, "invalid check timeout");
                                        $vsrv{checktimeout} = $1;
				} elsif ($rcmd =~ /^connecttimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or config_error($line, "invalid check timeout");
                                        $vsrv{connecttimeout} = $1;
				} elsif ($rcmd =~ /^negotiatetimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or config_error($line, "invalid check timeout");
                                        $vsrv{negotiatetimeout} = $1;
				} elsif ($rcmd =~ /^checkport\s*=\s*(.*)/){
					$1 =~ /(\d+)/ or config_error($line, "invalid port");
					( $1 > 0 && $1 < 65536 ) or config_error($line, "checkport must be in range 1..65536");
					$vsrv{checkport} = $1;
				} elsif ($rcmd =~ /^login\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "invalid login string");
					$vsrv{login} = $1;
				} elsif ($rcmd =~ /^passwd\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or config_error($line, "invalid password");
					$vsrv{passwd} = $1;
				} elsif ($rcmd =~ /^load\s*=\s*\"(.*)\"/) {
					$1 =~ /(\w+)/ or config_error($line, "invalid string for load testing");
					$vsrv{load} = $1;
					lc($1);
				} elsif ($rcmd =~ /^scheduler\s*=\s*(.*)/) {
					$1 =~ /(\w+)/ && ($1 eq "rr" || $1 eq "wrr" || $1 eq "lc" || $1 eq "wlc" || $1 eq "lblc" || $1 eq "lblcr" )
					    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 =~ /^netmask\s*=\s*(.*)/) {
					$1 =~ /(\d+\.\d+\.\d+\.\d+)/ or config_error($line, "invalid netmask");
					$vsrv{netmask} = $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 "ftp" || $1 eq "none")
					    or config_error($line, "service must be http, https, ftp or none");
					$vsrv{service} = $1;
				} elsif ($rcmd =~ /^sitename\s*=\s*(.*)/) {
					$1 =~ /(\w+)/ or config_error($line, "invalid sitename");
					$vsrv{sitename} = $1;
				} elsif ($rcmd =~ /^fallback\s*=\s*(.*)/) {    # Allow specification of a virtual-specific fallback host
					my $tmp = $1;
					($tmp =~ /(\d+\.\d+\.\d+\.\d+:\d+)/ || $tmp =~ /(\d+\.\d+\.\d+\.\d+)/) && $1
			    			or config_error($line, "invalid address for fallback server");
					$vsrv{fallback} = $tmp
				} else {
					config_error($line, "Unknown command $_");
				}
			}
		}
		next if ($_ =~ /^\s*$/ || $_ =~ /^\s*#/);
		if ($_ =~ /^checktimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or config_error($line, "invalid timeout value");
			$CHECKTIMEOUT = $1;
		} elsif ($_ =~ /^connecttimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or config_error($line, "invalid timeout value");
			$CONNECTTIMEOUT = $1;
		} elsif ($_ =~ /^negotiatetimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or config_error($line, "invalid timeout value");
			$NEGOTIATETIMEOUT = $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*\"(.*)\"/) {
			my $tmpLDIRLOG = $LDIRLOG;
			$LDIRLOG = $1;
			if (&ld_log("Reading file $CONFIG")) {
				config_error($line, "unable to open logfile: $1");
				$LDIRLOG = $tmpLDIRLOG;
			}
		} elsif ($_ =~ /^execute\s*=\s*(.*)/) {
			$LD_INSTANCE{$1} = 1;
		} elsif ($_ =~ /^foreground/) {
			$FOREGROUND = 1;
		} else {
			if ($_ =~ /^timeout\s*=\s*(.*)/) {
				config_error($line, "timeout directive deprciated in favour of checktimeout, negotiatetimeout or connecttimeout");
			}
			config_error($line, "Unknown command $_");
		}
	}
	close(CFGFILE);
	return(0);
}


sub add_real_server_range
{
	my ($line, $vsrv, $rsrv, $first, $last, $port, $flags) = (@_);

        my (@tmp, $first_i, $last_i, $i);
       
	if ( ($first_i=ip_to_decimal($first)) <0 ) {
		config_error($line, "Invalid IP address: $first");
	}
	if ( ($last_i=ip_to_decimal($last)) <0 ) {
		config_error($line, "Invalid IP address: $last");
	}

	if ($first_i>$last_i) {
		config_error($line, "Invalid Range: $first-$last: First value must be less than or equal to the second value");
	}

	# A for loop didn't seem to want to work
	$i=$first_i;
	while ( $i le $last_i ) {
		add_real_server($line, $vsrv, $rsrv, decimal_to_ip($i), $port, $flags);
		$i++;
	}
}

sub add_real_server
{
	my ($line, $vsrv, $rsrv, $rmts, $rmtp, $flags) = (@_);

	my $ref;
	my $realsrv=0;
	my $request;
	my $receive;

	$flags =~ /(\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 ($3 =~ /\"(.*)\",\s*\"(.*)\"/) {
			$request = $1;
			$receive = $2;
			unless($request=~/^\//){
				$request = "/" . $request;
			}
			push(@$rsrv, {"server"=>$rmts, "port"=>$rmtp, "forward"=>$fwd, "weight"=>$weight, "request"=>$request, "receive"=>$receive});
		} else {
			push(@$rsrv, {"server"=>$rmts, "port"=>$rmtp, "forward"=>$fwd, "weight"=>$weight});
		}
	} elsif ($2 =~ /\s+\"(.*)\",\s*\"(.*)\"/) {
		$request = $1;
		$receive = $2;
		unless($request=~/^\//){
			$request = "/" . $request;
		}
		push(@$rsrv, {"server"=>$rmts, "port"=>$rmtp, "forward"=>$fwd, "request"=>$request, "receive"=>$receive});
	} else {
		push(@$rsrv, {"server"=>$rmts, "port"=>$rmtp, "forward"=>$fwd});
	}

        my $real    = $vsrv->{"protocol"}.":".$rmts.":".$rmtp;
	my $virtual = $vsrv->{"protocol"}.":".&get_virtual($vsrv);
	foreach $r (@REAL){
		if($r->{"real"} eq $real){
			my $ref=$r->{"virtual"};
			push(@$ref, $virtual);
			$realsrv=1;
			last;
		}
	}
	if($realsrv==0){
		push(@REAL, { "real"=>$real, "virtual"=>[ $virtual ] });
	}
}


sub config_error
{
	my ($line, $msg) = @_;
	if (defined $opt_d || $initializing==1) {
		if ($line>0) {
			print STDERR "Error [$pid] reading file $CONFIG at line $line: $msg\n";
		} else {
			print STDERR "Error: $msg\n";
		}
	} else {
		if ($line>0) {
			&ld_log("Error [$pid] reading file $CONFIG at line $line: $msg");
		} else {
			 &ld_log("Error: $msg\n");
		}
	}
	if ($initializing) {
		&ld_rm_file("$RUNPID.$CFGNAME.pid");
		ld_exit(2, "config_error: Configuration Error");
	} 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} " .  &get_virtual($v) . " ";
		$$v{flags} .= "-s $$v{scheduler} " if defined ($$v{scheduler});
		if (defined $$v{persistent}) {
			$$v{flags} .= "-p $$v{persistent} ";
			$$v{flags} .= "-M $$v{netmask} " if defined ($$v{netmask});
		}
		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}:$$r{port}\/$uri";
				}
			} else {
				my $uri = $$v{request};
				$uri =~ s/^\///g;
				$$r{url} = "$$v{service}:\/\/$$r{server}:$$r{port}\/$uri";
                		$$r{request} = $$v{request} unless defined $$r{request};
                		$$r{receive} = $$v{receive};
			}
			if ($$v{checktype} eq "combined") {
				$$r{num_connects} = 999999;
			} else {
				$$r{num_connects} = -1;
			}
		}
		$$v{status} = -1;
		$$v{checktimeout} = $CHECKTIMEOUT if ($$v{checktimeout}<=0);
		$$v{connecttimeout} = $CONNECTTIMEOUT if ($$v{connecttimeout}<=0);
		$$v{connecttimeout} = $$v{checktimeout} if ($$v{connecttimeout}<=0);
		$$v{negotiatetimeout} = $NEGOTIATETIMEOUT if ($$v{negotiatetimeout}<=0);
		$$v{negotiatetimeout} = $$v{checktimeout} if ($$v{negotiatetimeout}<=0);
	}
}


sub ld_start
{
	# 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+)\s+mask\s+(.*)/) {
			$real_service = "$2 ".lc($1);
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4, "netmask"=>$5};
		} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)/) {
			$real_service = "$2 ".lc($1);
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4};
		} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)/) {
			$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 $nv;
	foreach $nv (@VIRTUAL) {
		my $nreal = $$nv{real};
		$$nv{status} = 0;
		my $real_service = &get_virtual($nv) . " "  . $$nv{protocol};
		if (exists($oldsrv{"$real_service"})) {
			# service exists, modify it
			&system_wrapper("$IPVSADM -E $$nv{flags}");
			&ld_log("Changing virtual server: " . &get_virtual($nv));
			my $ov = $oldsrv{&get_virtual($nv) . " " . $$nv{protocol}};
			my $or = $$ov{real};
			foreach $nr (@$nreal) {
				if (exists($$or{"$$nr{server}:$$nr{port}"})) {
					&system_wrapper("$IPVSADM -e $$nv{proto} " . &get_virtual($nv) . " -R $$nr{server}:$$nr{port} $$nr{forw} $$nr{wght}");
					$$nr{status} = 1;
					$$nv{status}++;
					&ld_log("Changing real server: $$nr{server}:$$nr{port} ($$nv{status} x " . &get_virtual($nv) . ")\n");
					delete($$or{"$$nr{server}:$$nr{port}"});
				} else {
					$$nr{status} = 0;
				}
			}
			# remove remaining entries for real servers
			foreach $k (keys %$or) {
				&system_wrapper("$IPVSADM -d $$nv{proto} " . &get_virtual($nv) . " -R $k");
				print ("Removing real server: $$nr{server}:$$nr{port} ($$nv{status} x " . &get_virtual($nv) . ")\n");
			}
			delete $oldsrv{&get_virtual($nv) . " " . $$nv{protocol}};
		} else {
			# no such service, create a new one
			&system_wrapper("$IPVSADM -A $$nv{flags}");
			foreach $nr (@$nreal) {
				$$nr{status} = 0;
			}
			&ld_log("Adding virtual server: " . &get_virtual($nv));
		}

		&fallback_on($nv);
	}

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


sub ld_cmd_children
{
	my ($cmd, %children) = (@_);
	# instantiate other ldirectord, if specified
	my $child;
	foreach $child (keys %children) {
		&system_wrapper("$LDIRECTORD $child $cmd");
	}
}


sub ld_stop
{
	foreach $v (@VIRTUAL) {
		my $real = $$v{real};
		foreach $r (@$real) {
			if ($$r{status}>0) {
				&system_wrapper("$IPVSADM -d $$v{proto} " . &get_virtual($v) . " -R $$r{server}:$$r{port}");
				$$r{status} = 0;
				$$v{status}--;
				&ld_log("Removing real server: $$r{server}:$$r{port} ($$v{status} x " . &get_virtual($v) );
			}
		}
		&system_wrapper("$IPVSADM -D $$v{proto} " .  &get_virtual($v));
		&ld_log("Removing virtual server: " .  &get_virtual($v));
	}
}


sub ld_main
{
	# Main failover checking code
	while (1) {
		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}:$$r{port}$/, @real_checked)){
					if ($$v{checktype} eq "negotiate" || $$r{num_connects}>=$$v{num_connects}) {
						&ld_debug(2, "Checking negotiate: real server=$$r{server}:$$r{port} (virtual: " .  &get_virtual($v) . ")");
						if ($$v{service} eq "http") {
							$$r{num_connects} = 0 if (check_http($v, $r));
							# my $req = new HTTP::Request(GET=>"$$r{url}");
							# $ua->register($req, \&http_received);
						} elsif ($$v{service} eq "https") {
							$$r{num_connects} = 0 if (check_https($v, $r));
						} elsif ($$v{service} eq "ftp") {
							$$r{num_connects} = 0 if (check_ftp($v, $r));
						} else {
							$$r{num_connects} = 0 if (check_none($v, $r));
						}
					} elsif ($$v{checktype} eq "connect" and $$v{protocol} ne "udp") {
						&ld_debug(2, "Checking connect: server=$$r{server}");
						check_connect($v, $r);
					} elsif ($$v{checktype} eq "off") {
						&ld_debug(2, "Checking off: No real or fallback servers to be added\n");
					} elsif ($$v{checktype} eq "combined") {
						&ld_debug(2, "Checking combined-connect: server=$$r{server}");
						if (check_connect($v, $r)) {
							$$r{num_connects}++;
						} else {
							$$r{num_connects} = 999999;
						}
					}
						
					push(@real_checked, "$$v{protocol}:$$r{server}:$$r{port}");
				}
			}
			# $ua->wait($$v{checktimeout});
		}
		check_cfgfile();
		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
{
	use LWP::UserAgent;
	my ($v, $r) = @_;
	my $ua = new LWP::UserAgent;
	$ua->agent("LinuxDirector/0.1".$ua->agent);
	$ua->timeout($$v{negotiatetimeout});
	my $req = new HTTP::Request(GET=>"$$r{url}");
	my $res = $ua->request($req);
	my $recstr = $$r{receive};
	if ($res->is_success && (!($recstr =~ /.+/) || $res->content =~ /$recstr/)) {
		service_set($v, $r, "up");
		return 1;
	} else {
		service_set($v, $r, "down");
		return 0;
	}
}


sub check_https
{
	my ($v, $r) = @_;
	use Net::SSLeay;
	$Net::SSLeay::trace = 0;
	$uri = $$v{request};
	my ($page, $result, %headers) = Net::SSLeay::get_https($$r{server}, $$r{port}, $uri);
	my $recstr = $$r{receive};
	if ($result =~ /ERROR/) {
		service_set($v, $r, "down");
		return 0;
	}
	if ( !($recstr =~ /.+/) || $page =~ /$recstr/ ) {
		service_set($v, $r, "up");
		return 1;
	}
	service_set($v, $r, "down");
	return 0;
}


sub check_connect
{
	my ($v, $r) = @_;
	undef $EVAL_ERROR, $result;

	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
	eval {
		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		&ld_debug(4, "Timeout is $$v{checktimeout}");
		alarm $$v{checktimeout};
		my $result = open_socket( $$r{server}, $port, $$v{protocol} );
		if ($result == 0) {
			# Failure to open the socket
			die("Couldn't open socket to $$r{server}:$port");
		} else {
			&ld_debug(3, "Connected to $1 (port $port)");
		}
	};
	alarm 0; # Cancel the alarm
	if ($@) {
		&service_set($v, $r, "down");
		&ld_debug(3, "Deactivating service $$r{server}:$$r{port}: $@");
		return 0;
	} else {
		&service_set($v, $r, "up");
		&ld_debug(3, "Activating service $$r{server}:$$r{port}");
		return 1;
	}
}


sub check_ftp
{
	use Net::FTP;
	my ($v, $r) = @_;
	my $ftp;
        local *READ_FH;
	local *WRITE_FH;

	pipe(\*READ_FH, \*WRITE_FH);
	select(\*WRITE_FH); $| = 1; select(STDERR);

	unless ($ftp = Net::FTP->new("$$r{server}:$$r{port}", Timeout=>$$v{negotiatetimeout})) {
		service_set($v, $r, "down");
		return 0;
	}
	$ftp->login($$v{login}, $$v{passwd});
	$ftp->cwd("/");
	$ftp->binary();
	$ftp->get("$$r{request}", \*WRITE_FH);
	$ftp->quit();
	close(\*WRITE_FH);
	while(<READ_FH>) {
		if (/$$r{receive}/) {
	 		service_set($v, $r, "up");
			close(\*READ_FH);
			return 1
		}
	}
	close(\*READ_FH);

	service_set($v, $r, "down");
	return 0;
}


# check_none
# Dummy function to check service if service type is none.
# Just activates the real server
sub check_none
{
	my ($v, $r) = @_;
	service_set($v, $r, "up");
	return 1;
}


# service_set
# Used to bring up and down real servers.
# This is the function you should call if you want to bring a real server up or down.
# This function is safe to call regrdless of the current state of a real server.
# Do _not_ call _service_up or _service_down directly.
# pre: v: virtual that the real service belongs to
#         Only used to determine the protocol of the service
#      r: real server to take down
#      state: up or down
#             up to bring the real service up
#             down to bring the real service up
# post: The real server is brough up or down for each virtual service
#       it belongs to.
# return: none
sub service_set()
{
	my ($v, $r, $state) = @_;

	my ($real, $virtual, $virt);

        # Return if the real server is already in the desired state
	return if ($$r{status}!=0 and $state=~/up/i);
	return if ($$r{status}!=1 and $state=~/down/i);

        # Find the real server in @REAL
	foreach $real (@REAL) {
		if($real->{"real"} eq "$$v{protocol}:$$r{server}:$$r{port}"){
			$virtual = $real->{"virtual"};
			last;
		}
	}
	return unless (defined($virtual));
	
	# Check each virtual service for the real server and make
	# changes as neccessary
	foreach $v (@VIRTUAL){
		my $qry=$$v{protocol} . ":" . &get_virtual($v);
		if (grep(/^$qry$/, @$virtual)) {
			if ($state=~/up/i) {
				$$r{status}=0;
				_service_up($v, $r);
				&ld_debug(2, "Enabling server=$$r{server}");
			} elsif ($state=~/down/i) {
				$$r{status}=1;
				_service_down($v, $r);
				&ld_debug(2, "Disabling server=$$r{server}");
			}
		}
	}
}


# _service_up
# Bring a real service up if it is down
# Should be called by set_service only
# I.e. If you want to change the state of a real server call set_service.
#      If you call this function directly then ldirectord will lose track 
#      of the state of real servers.
# pre: v: reference to virtual service to with the real server belongs
#      r: refernece to the real server to take down
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none   
sub _service_up
{
	my ($v, $r) = @_;
	if ($$r{status}==0) {
		&system_wrapper("$IPVSADM -a $$v{proto}  " . &get_virtual($v) . " -R $$r{server}:$$r{port} $$r{forw} $$r{wght}");
		$$r{status} = 1;
		$$v{status}++;
		&ld_log("Adding real server: $$r{server}:$$r{port} ($$v{status} x " .  &get_virtual($v) . ")");
		&fallback_off($v);
	}
}


# _service_down
# Bring a real service down if it is up
# Should be called by set_service only
# I.e. if you want to change the state of a real server call set_service.
#      If you call this function directly then ldirectord will lose track 
#      of the state of real servers.
# pre: v: reference to virtual service to with the real server belongs
#      r: refernece to the real server to take down
# post: real service is taken down from the respective virtual service
#       if it is active
# return: none   
sub _service_down
{
	my ($v, $r) = @_;
	if ($$r{status}==1) {
		&system_wrapper("$IPVSADM -d $$v{proto} " .  &get_virtual($v) . " -R $$r{server}:$$r{port}");
		$$r{status} = 0;
		$$v{status}--;
		&ld_log("Removing real server: $$r{server}:$$r{port} ($$v{status} x " .  &get_virtual($v) . ")");
		&fallback_on($v);
	}
}


# fallback_on
# Turn on the fallback server for a virtual service if it is inactive
# pre: virtaual: virtual to turn fallback service on for
# post: fallback server is turned on if it was inactive
# return: none
sub fallback_on 
{
	my ($virtual) = (@_);

	my $fallback=&fallback_find($virtual);
	if (defined $fallback and $$virtual{status}==0) {
		# turn on fallback service
		&system_wrapper("$IPVSADM -a $$virtual{proto} " . &get_virtual($virtual) . " -R $fallback");
		&ld_log("Starting fallback server for: " . &get_virtual($virtual) . " ($fallback)");
	}
}


# fallback_off
# Turn off the fallback server for a virtual service if it is active
# pre: virtaual: virtual to turn fallback service off for
# post: fallback server is turned off if it was active
# return: none
sub fallback_off 
{
	my ($virtual) = (@_);

	my $fallback=&fallback_find($virtual);
	if (defined $fallback and $$virtual{status}==1) {
		# turn off fallback service
		&system_wrapper("$IPVSADM -d $$virtual{proto} " . &get_virtual($virtual) . " -R $fallback");
		&ld_log("Turning off fallback server for: " . &get_virtual($virtual) . " ($fallback)");
	}
}


# fallback_find
# Determine the fallback for a virtual service
# pre: virtual: reference to a virtual service
# post: none
# return: $virtual->{"fallback"} if defined
#         else $FALLBACK if defined
#         else undef
sub fallback_find 
{
	my ($virtual) = (@_);

	if( defined $virtual->{"fallback"} ) {
		return($virtual->{"fallback"});
	} elsif ( defined($FALLBACK) ) {
		return($FALLBACK);
	}

	return;
}
  

sub check_cfgfile
{
	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime) = stat($CONFIG);
	return if ($stattime==$mtime);
	$stattime = $mtime;
	my ($chs, $lctr) = (0, 0);
	open(CFGFILE, "<$CONFIG") || config_error(0, "can not open file $CONFIG");
	while (<CFGFILE>) {
		$lctr++;
		$chs += (4*($lctr%3)+3)*unpack("%32C*", $_);
	}
	close(CFGFILE);
	if (defined $checksum && $chs!=$checksum) {
		&ld_log("Configuration file '$CONFIG' has changed on disk");
		if ($AUTOCHECK eq "yes") {
			&ld_log(" - reread new configuration");
			reread_config();
		} else {
			&ld_log(" - ignore new configuration\n");
		}
		if (-x $CALLBACK) {
			&system_wrapper("$CALLBACK $CONFIG");
		}
	}
	$checksum = $chs;
}


# ld_log
# Log a message to a file.
# File is opened and closed again as a primative means to
# make log rotation work
# pre: message: Message to write
# post: message and timetsamp is written to log file
# return: 0 on success
#         1 on error

sub ld_log 
{
	my ($message) = (@_);

        my $now = localtime()."|$CFGNAME";

	&ld_debug(2, $message);

        open(LOGFILE, ">>$LDIRLOG") || return(1);
	chomp $message;
        print LOGFILE "[$now] $message\n" || return(1);
        close(LOGFILE) || return(1);;

	return(0);
}


# ld_debug
# Log a message to a STDOUT.
# pre: priority: priority of message
#      message: Message to write
# post: message is written to STDOUT if $DEBUG >= priority
# return: none

sub ld_debug 
{
	my ($priority, $message) = (@_);

	if ( $DEBUG >= $priority ){
	  chomp $message;
	  print STDERR "DEBUG${priority}: $message\n";
	}
}


# 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

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

	system(@_) == 0 or &ld_log("system(@args) failed");
}


# ld_rm_file
# Remove a file, symink, or anything that isn't a directory
# and exists
# pre: filename: file to delete
# post: If filename does not exist or is a directory an
#       error state is reached
#       Else filename is delete
#       If $DEBUG >=2 errors are logged
# return: 0 on success
#         -1 on error

sub ld_rm_file
{
	my ($filename)=(@_);
	
	my ($status);

	if(-d "$filename"){ 
		&ld_debug(2, "ld_rm_file: $filename is a directory, skipping");
		return(-1); 
	}
	if(! -e "$filename"){ 
		&ld_debug(2, "ld_rm_file: $filename doesn't exist, skipping");
		return(-1); 
	}
	$status = unlink($filename);
	if($status!=1){
		&ld_debug(2, "ld_rm_file: Error deleting: $filename: $!");
	}
	return(($status==1)?0:-1)
}


# See if a number is an octet, that is >=0 and <=255
# pre: alleged_octet: the octect to test
# post: 1 if the alleged_octet is an octet
#       0 otherwise

sub is_octet 
{
	  my ($alleged_octet)=(@_);

	  if($alleged_octet<0){ return 0; }
	  if($alleged_octet>255){ return 0; }

	  return(1);
}


# is_ip
# Check that a given string is an IP address
# pre: alleged_ip: string representing ip address
# post: 1 if alleged_ip is a valid ip address
#       0 otherwise

sub is_ip 
{
	  my ($alleged_ip)=(@_);

	  #If we don't have four, . delimited numbers then we have no hope
	  unless($alleged_ip=~m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { return 0; }

	  #Each octet mist be >=0 and <=255
	  unless(&is_octet($1)){ return 0; }
	  unless(&is_octet($2)){ return 0; }
	  unless(&is_octet($3)){ return 0; }
	  unless(&is_octet($4)){ return 0; }

	  return(1);
}


# ip_to_decimal
# Turn an IP address given as a dotted quad into a decimal
# pre: ip_address: string representing IP address
# post: -1 if an error occurs
#       decimal representation of IP address otherwise

sub ip_to_decimal 
{
	  my ($ip_address)=(@_);

	  unless(&is_ip($ip_address)){ return(-1); }
	  unless($ip_address=~m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){ return(-1); }

	  return(((((($1<<8)+$2)<<8)+$3)<<8)+$4);
}

# decimal_to_ip
# Turn an IP address given as a dotted quad into a decimal
# pre: ip_address: string representing IP address
# post: -1 if an error occurs
#       decimal representation of IP address otherwise

sub decimal_to_ip 
{
	my ($ip_address)=(@_);

	my $result = "";

	return(sprintf(
		"%d.%d.%d.%d",
		($ip_address>>24)&255,
		($ip_address>>16)&255,
		($ip_address>>8)&255,
		$ip_address&255
	));
}

# get_virtual
# Get the service for a virtual
# Will be of the form IP:port for a UDP or TCP service
# Will be of the form fwmark for a Firewall Mark service
sub get_virtual
{
	my ($nv) = (@_);

	if ($nv->{"protocol"} eq "fwm"){
		return $nv->{"fwm"};
	} else {
        	return $nv->{"server"} . ":" . $nv->{"port"};
	}
}



# ld_exit
# Exit and log a message
# pre: exit_status: Integer exit status to exit with
#                   0 wiil be used if parameter is omitted
#      message: Message to log when exiting. May be omitted
# post: If exit_status is non-zero or $DEBUG>2 then
#       message logged.
#       Programme exits with exit_status
# return: does not return

sub ld_exit
{
	my ($exit_status, $message)=(@_);
	unless(defined($exit_status)) { $exit_status=0; }
	unless(defined($exit_status)) { $message=""; }

	if ($exit_status!=0 or $DEBUG>2) {
		&ld_log("Exiting with exit_status $exit_status: $message");
	}
	exit($exit_status);
}


sub open_socket
{
	use Socket;
	my ($remote, $port, $protocol) = @_;
	my ($iaddr, $paddr, $pro, $result);

	$iaddr = inet_aton($remote) || die "no host: $remote";
	$paddr = sockaddr_in($port, $iaddr);
	$pro = getprotobyname($protocol);
	socket(SOCK, PF_INET, SOCK_STREAM, $pro) || die "socket: $!";
	$result = connect(SOCK, $paddr);
	close(SOCK) || die "close: $!" if ($result);
	return $result;
}


# daemon
# Close and fork to become a daemon.
#
# Notes from unix programmer faq
# http://www.landfield.com/faqs/unix-faq/programmer/faq/
#
# Almost none of this is necessary (or advisable) if your daemon is being
# started by `inetd'.  In that case, stdin, stdout and stderr are all set up
# for you to refer to the network connection, and the `fork()'s and session
# manipulation should *not* be done (to avoid confusing `inetd').  Only the
# `chdir()' and `umask()' steps remain as useful.
#
# Gratuitously over documented, because it can be
#
# Writen by Horms, horms@vergenet.net for an unrelated project while
# working for Zip World, http://www.zipworld.com.au/, 1997-1999.

sub ld_daemon 
{
	return if defined $FOREGROUND;

	# `fork()' so the parent can exit, this returns control to the command
	# line or shell invoking your program.  This step is required so that
	# the new process is guaranteed not to be a process group leader. The
	# next step, `setsid()', fails if you're a process group leader.
	&ld_daemon_become_child();

	# setsid()' to become a process group and session group leader. Since a
	# controlling terminal is associated with a session, and this new
	# session has not yet acquired a controlling terminal our process now
	# has no controlling terminal, which is a Good Thing for daemons.
	if(POSIX::setsid()<0){
		&ld_exit(-1, "ld_daemon: Could not setsid");
	}

	# fork()' again so the parent, (the session group leader), can exit.
	# This means that we, as a non-session group leader, can never regain a
	# controlling terminal.
	&ld_daemon_become_child();

	# `chdir("/")' to ensure that our process doesn't keep any directory in
	# use. Failure to do this could make it so that an administrator
	# couldn't unmount a filesystem, because it was our current directory.
	if(chdir("/")<0){
		&ld_exit(-1, "ld_daemon: Could not chdir");
	}

	# `umask(0)' so that we have complete control over the permissions of
	# anything we write. We don't know what umask we may have inherited.
	umask(0);

	# `close()' fds 0, 1, and 2. This releases the standard in, out, and
	# error we inherited from our parent process. We have no way of knowing
	# where these fds might have been redirected to. Note that many daemons
	# use `sysconf()' to determine the limit `_SC_OPEN_MAX'.  `_SC_OPEN_MAX'
	# tells you the maximun open files/process. Then in a loop, the daemon
	# can close all possible file descriptors. You have to decide if you
	# need to do this or not.  If you think that there might be
	# file-descriptors open you should close them, since there's a limit on
	# number of concurrent file descriptors.
	close(STDIN);
	close(STDOUT);
	close(STDERR);

	# Establish new open descriptors for stdin, stdout and stderr. Even if
	# you don't plan to use them, it is still a good idea to have them open.
	# The precise handling of these is a matter of taste; if you have a
	# logfile, for example, you might wish to open it as stdout or stderr,
	# and open `/dev/null' as stdin; alternatively, you could open
	# `/dev/console' as stderr and/or stdout, and `/dev/null' as stdin, or
	# any other combination that makes sense for your particular daemon.
	if(open(STDIN, "</dev/null")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/null");
	}
	if(open(STDOUT, ">>/dev/console")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/console");
	}
	if(open(STDERR, ">>/dev/console")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/console");
	}
}


# ld_daemon_become_child
# Fork, kill parent and return child process
# pre: none
# post: process forkes and parent exits
#       All preocess exit with exit status -1 if an error occurs
# return: parent: exits
#         child: none  (this is the process that returns)
# Writen by Horms, horms@vergenet.net for an unrelated project while
# working for Zip World, http://www.zipworld.com.au/, 1997-1999.
sub ld_daemon_become_child 
{
	my($status);

	$status=fork();

	if ($status<0){
		&ld_exit(-1, "ld_daemon_become_child: Could not fork: $!");
	}
	if ($status>0){
		&ld_exit(0, "ld_daemon_become_child: Parent exiting as it should");
	}
}

