l7directord/l7directord

   1 #!/usr/bin/perl
   2 ######################################################################
   3 # l7directord
   4 # Linux Director Daemon - run "perldoc l7directord" for details
   5 #
   6 # 2005-2008 (C) NTT COMWARE
   7 #
   8 # License:   GNU General Public License (GPL)
   9 #
  10 # This program is developed on similar lines of ldirectord. It handles
  11 # l7vsadm and monitoring of real servers.
  12 #
  13 # The version of ldirectord used as a reference for this l7directord is
  14 # ldirectord,v 1.77.2.32 2005/09/21 04:00:41
  15 #
  16 # Note : * The existing code of ldirectord that is not required for
  17 #          l7directord is also maintained in the program but is
  18 #          commented out.
  19 #
  20 # This program is free software; you can redistribute it and/or
  21 # modify it under the terms of the GNU General Public License as
  22 # published by the Free Software Foundation; either version 2 of the
  23 # License, or (at your option) any later version.
  24 #
  25 # This program is distributed in the hope that it will be useful, but
  26 # WITHOUT ANY WARRANTY; without even the implied warranty of
  27 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  28 # General Public License for more details.
  29 #
  30 # You should have received a copy of the GNU General Public License
  31 # along with this program; if not, write to the Free Software
  32 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  33 # 02110-1301 USA
  34 ######################################################################
  35
  36 # Revision History :
  37 #   0.5.0-0: Added code related to Sorry server and Max connection
  38 #            - 2006/11/03 NTT COMWARE
  39 #   1.0.0-0: Added code related to weight of real server and QoS
  40 #            - 2007/10/12 NTT COMWARE
  41 #   1.0.1-0: Added the code below.
  42 #            configuration of realdowncallback, realrecovercallback,
  43 #            and sessionless module.
  44 #            - 2007/12/28 NTT COMWARE
  45 #   1.0.2-0: Added the code below.
  46 #            cookie insert with X-Forwarded-For module(cinsert_xf)
  47 #            - 2008/1/14 Shinya TAKEBAYASHI
  48 #   2.0.0-0: Added code related to sslid module.
  49 #            cinsert_xf module is marged into cinsert module.
  50 #            Added code related to syntax test of configuration.
  51 #            Expanded checkcount setting to all service check.
  52 #            - 2008/03/25 Norihisa NAKAI
  53 #   2.1.0-0: Changed helthcheck logic to multi-process.
  54 #            - 2008/12/17 NTT COMWARE
  55 #   2.1.1-0: Fix 'Range iterator outside integer range' in parse_real.
  56 #            - 2009/01/06 NTT COMWARE
  57 #   2.1.2-0: Added code related to some module. See below.
  58 #            (cpassive, crewrite, pfilter, url, ip)
  59 #            Add custom healthcheck.
  60 #            (checktype=custom, customcheck=exec_command)
  61 #            - 2009/02/14 NTT COMWARE
  62
  63 use 5.006;
  64 use strict;
  65 use warnings;
  66 use Getopt::Long qw(:config posix_default);
  67 use Sys::Hostname;
  68 use POSIX qw(:sys_wait_h :signal_h);
  69 use Sys::Syslog qw(:DEFAULT setlogsock);
  70 use English;
  71 use Fatal qw(open close);
  72 use Cwd qw(abs_path);
  73 use Data::Dumper;
  74 use Time::HiRes qw(sleep);
  75 use IO::Handle;
  76
  77 # current version
  78 our $VERSION     = '2.1.2-0';
  79 our $COPYRIGHT   = 'Copyright (C) 2009 NTT COMWARE CORPORATION';
  80
  81 # default global config values
  82 our %GLOBAL = (
  83     logfile          => '/var/log/l7vs/l7directord.log',
  84     autoreload       => 0,
  85     checkcount       => 1,
  86     checkinterval    => 10,
  87     retryinterval    => 10,
  88     configinterval   => 5,
  89     checktimeout     => 5,
  90     negotiatetimeout => 5,
  91     supervised       => 0,
  92     quiescent        => 1,
  93     virtual          => undef,
  94     execute          => undef,
  95     fallback         => undef,
  96     callback         => undef,
  97     );
  98
  99 # default virtual config values
 100 our %VIRTUAL = (
 101     real                => undef,
 102     module              => { name => 'sessionless', key => q{} },
 103     scheduler           => 'rr',
 104     protocol            => 'tcp',
 105     checktype           => 'negotiate',
 106     service             => undef,
 107     checkport           => undef,
 108     maxconn             => 0,
 109     qosup               => 0,
 110     qosdown             => 0,
 111     sorryserver         => { ip => '0.0.0.0', port => 0 },
 112     request             => undef,
 113     receive             => undef,
 114     httpmethod          => 'GET',
 115     virtualhost         => undef,
 116     login               => q{},
 117     passwd              => q{},
 118     database            => q{},
 119     realdowncallback    => undef,
 120     realrecovercallback => undef,
 121     customcheck         => undef,
 122     # can override
 123     checkcount          => undef,
 124     checkinterval       => undef,
 125     retryinterval       => undef,
 126     checktimeout        => undef,
 127     negotiatetimeout    => undef,
 128     quiescent           => undef,
 129     fallback            => undef,
 130     );
 131
 132 # default real config values
 133 our %REAL = (
 134     weight              => 1,
 135     forward             => 'masq',
 136     # can override
 137     request             => undef,
 138     receive             => undef,
 139     );
 140
 141 # current config data
 142 our %CONFIG = %GLOBAL;
 143
 144 # config file data
 145 our %CONFIG_FILE = (
 146     path            => undef,
 147     filename        => undef,
 148     checksum        => undef,
 149     stattime        => undef,
 150     );
 151
 152 # process environment
 153 our %PROC_ENV = (
 154     l7directord => $0,
 155     l7vsadm     => undef,
 156     pid_prefix  => '/var/run/l7directord',
 157     hostname    => undef,
 158     );
 159
 160 # process status
 161 our %PROC_STAT = (
 162     pid             => $PID,
 163     initialized     => 0,
 164     log_opened      => 0,
 165     health_checked  => 0,
 166     halt            => undef,
 167     reload          => undef,
 168     );
 169
 170 # debug level
 171 our $DEBUG_LEVEL = 0;
 172
 173 # health check process data
 174 our %HEALTH_CHECK  = ();
 175
 176 # real server health flag
 177 our $SERVICE_UP   = 0;
 178 our $SERVICE_DOWN = 1;
 179
 180 # section virtual sub config prefix
 181 our $SECTION_VIRTUAL_PREFIX = "    ";
 182
 183 main();
 184
 185 # main
 186 # Main method of this program.
 187 # parse command line and run each command method.
 188 sub main {
 189     my $cmd_func = {
 190         start         => \&cmd_start,
 191         stop          => \&cmd_stop,
 192         restart       => \&cmd_restart,
 193         'try-restart' => \&cmd_try_restart,
 194         reload        => \&cmd_reload,
 195         status        => \&cmd_status,
 196         configtest    => \&cmd_configtest,
 197         version       => \&cmd_version,
 198         help          => \&cmd_help,
 199         usage         => \&cmd_usage,
 200         };
 201
 202     # change program name for removing `perl' string from `ps' command result.
 203     my $ps_name = @ARGV ? $PROGRAM_NAME . " @ARGV"
 204                         : $PROGRAM_NAME;
 205     $PROGRAM_NAME = $ps_name;
 206
 207     my $cmd_mode = parse_cmd();
 208     if ( !defined $cmd_mode || !exists $cmd_func->{$cmd_mode} ) {
 209         $cmd_mode = 'usage';
 210     }
 211     if ($cmd_mode ne 'help' && $cmd_mode ne 'version' && $cmd_mode ne 'usage') {
 212         initial_setting();
 213     }
 214
 215     # execute command.
 216     my $cmd_result = &{ $cmd_func->{$cmd_mode} }();
 217
 218     ld_exit( $cmd_result, _message_only('INF0008') );
 219 }
 220
 221 # parse_cmd
 222 # Parse command line (ARGV)
 223 sub parse_cmd {
 224     # configtest or help command
 225     my $cmd_mode = parse_option();
 226
 227     # other command
 228     if (!defined $cmd_mode && @ARGV) {
 229         $cmd_mode = pop @ARGV;
 230     }
 231     return $cmd_mode;
 232 }
 233
 234 # parse_option
 235 # Parse option strings by Getopt::Long
 236 sub parse_option {
 237     my $cmd_mode = undef;
 238
 239     # default option value
 240     my $debug   = undef;
 241     my $help    = undef;
 242     my $test    = undef;
 243     my $version = undef;
 244
 245     # parse command line options
 246     my $result = GetOptions(
 247         'd:3'       => \$debug,   # debug mode, arg: debug level (default 3)
 248         'h|help'    => \$help,    # show help message
 249         't'         => \$test,    # config syntax test
 250         'v|version' => \$version, # show version
 251         );
 252
 253     if ($result) {
 254         # set debug level
 255         if (defined $debug) {
 256             $DEBUG_LEVEL = $debug;
 257         }
 258
 259         # set command mode
 260         if (defined $help) {
 261             $cmd_mode = 'help';
 262         }
 263         elsif (defined $version) {
 264             $cmd_mode = 'version';
 265         }
 266         elsif (defined $test) {
 267             $cmd_mode = 'configtest';
 268         }
 269     }
 270     else {
 271         $cmd_mode = 'usage';
 272     }
 273
 274     return $cmd_mode;
 275 }
 276
 277 # initial_setting
 278 # Initialize file path settings.
 279 sub initial_setting {
 280     # search config and l7vsadm
 281     $PROC_ENV{l7vsadm} = search_l7vsadm_file();
 282     $CONFIG_FILE{path} = search_config_file();
 283
 284     # get config file name exclude `.cf' or `.conf'
 285     ( $CONFIG_FILE{filename} )
 286         = $CONFIG_FILE{path} =~ m{([^/]+?)(?:\.cf|\.conf)?$};
 287
 288     # get hostname
 289     $PROC_ENV{hostname}
 290         = defined $ENV{HOSTNAME} ? $ENV{HOSTNAME}
 291         :                          ( POSIX::uname() )[1]
 292         ;
 293 }
 294
 295 # search_config_file
 296 # Search l7directord.cf file from search path.
 297 sub search_config_file {
 298     my $config_file = undef;
 299     my @search_path = qw(
 300         /etc/ha.d/conf/l7directord.cf
 301         /etc/ha.d/l7directord.cf
 302         ./l7directord.cf
 303         );
 304
 305     if (@ARGV) {
 306         $config_file = $ARGV[0];
 307         if (!-f $ARGV[0]) {
 308             init_error( _message_only('ERR0404', $config_file) );
 309         }
 310     }
 311     else {
 312         for my $file (@search_path) {
 313             if (-f $file) {
 314                 $config_file = $file;
 315                 last;
 316             }
 317         }
 318         if (!defined $config_file) {
 319             init_error( _message_only('ERR0405', $config_file) );
 320         }
 321     }
 322
 323     return abs_path($config_file);
 324 }
 325
 326 # search_l7vsadm_file
 327 # Search l7vsadm file from search path.
 328 sub search_l7vsadm_file {
 329     my $l7vsadm_file = undef;
 330     my @search_path = qw(
 331         /usr/sbin/l7vsadm
 332         /sbin/l7vsadm
 333         ./l7vsadm
 334         );
 335
 336     for my $file (@search_path) {
 337         if (-x $file) {
 338             $l7vsadm_file = $file;
 339             last;
 340         }
 341     }
 342     if (!defined $l7vsadm_file) {
 343         init_error( _message_only('ERR0406', $l7vsadm_file) );
 344     }
 345
 346     return abs_path($l7vsadm_file);
 347 }
 348
 349 # cmd_start
 350 # Start process
 351 # Called if command argument is start
 352 # return: 0 if success
 353 #         1 if old process id is found.
 354 sub cmd_start {
 355     set_ld_handler();
 356     read_config();
 357
 358     ld_log( _message('INF0001', $PROGRAM_NAME) );
 359
 360     ld_setup();
 361
 362     my $oldpid = read_pid();
 363
 364     # already other process is running
 365     if ($oldpid) {
 366         print {*STDERR} _message_only('INF0103', $oldpid) . "\n";
 367         return 1;
 368     }
 369
 370     # supervised or debug mode (not daemon)
 371     if ($CONFIG{supervised} || $DEBUG_LEVEL > 0) {
 372         ld_log( _message( 'INF0002', $VERSION, $PID, $CONFIG_FILE{path} ) );
 373     }
 374     # otherwise (daemon)
 375     else {
 376         ld_daemon();
 377         ld_log( _message( 'INF0003', $VERSION, $CONFIG_FILE{path} ) );
 378     }
 379
 380     write_pid( $PROC_STAT{pid} );
 381     ld_cmd_children('start');
 382     ld_main();
 383     ld_cmd_children('stop');
 384     remove_pid();
 385
 386     return 0;
 387 }
 388
 389 # cmd_stop
 390 # Send stop signal (TERM)
 391 # Called if command argument is stop
 392 # return: 0 if success
 393 #         2 if old process id is not found.
 394 #         3 if signal failed.
 395 sub cmd_stop {
 396     my ($oldpid, $stalepid) = read_pid();
 397
 398     # process is not running
 399     if (!$oldpid) {
 400         if ($stalepid) {
 401             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 402             print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
 403         }
 404         print {*STDERR} _message_only('INF0104') . "\n";
 405         return 2;
 406     }
 407
 408     # signal TERM
 409     my $signaled = kill 15, $oldpid;
 410     if ($signaled != 1) {
 411         print {*STDERR} _message('WRN0003', $oldpid);
 412         return 3;
 413     }
 414
 415     # wait and see
 416     while (1) {
 417         read_pid() or last;
 418         sleep 1;
 419     }
 420     return 0;
 421 }
 422
 423 # cmd_restart
 424 # Restart process
 425 # Called if command argument is restart
 426 # return: see cmd_start return
 427 sub cmd_restart {
 428     # stop and ignore result
 429     cmd_stop();
 430
 431     # start
 432     my $status = cmd_start();
 433
 434     return $status;
 435 }
 436
 437 # cmd_try_restart
 438 # Trying restart process
 439 # Called if command argument is try-restart
 440 # return: see cmd_start, cmd_stop return
 441 sub cmd_try_restart {
 442     # stop
 443     my $stop_result = cmd_stop();
 444
 445     # start only if stop succeed
 446     if ($stop_result != 0) {
 447         return $stop_result;
 448     }
 449
 450     # start
 451     my $status = cmd_start();
 452
 453     return $status;
 454 }
 455
 456 # cmd_reload
 457 # Send reload signal (HUP)
 458 # Called if command argument is reload
 459 # return: 0 if success
 460 #         2 if old process id is not found.
 461 #         3 if signal failed.
 462 sub cmd_reload {
 463     read_config();
 464     my ($oldpid, $stalepid) = read_pid();
 465     if (!$oldpid) {
 466         if ($stalepid) {
 467             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 468             print {*STDERR} _message_only( 'INF0102', $pid_file, $CONFIG_FILE{path} ) . "\n";
 469         }
 470         print {*STDERR} _message_only('INF0104') . "\n";
 471         return 2;
 472     }
 473
 474     # signal HUP
 475     my $signaled = kill 1, $oldpid;
 476     if ($signaled != 1) {
 477         print {*STDERR} _message('WRN0004', $oldpid);
 478         return 3;
 479     }
 480     return 0;
 481 }
 482
 483 # cmd_status
 484 # Show process id of running
 485 # Called if command argument is status
 486 # return: 0 if success
 487 #         2 if old process id is not found.
 488 sub cmd_status {
 489     my ($oldpid, $stalepid) = read_pid();
 490     if (!$oldpid) {
 491         if ($stalepid) {
 492             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 493             print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
 494         }
 495         print {*STDERR} _message_only('INF0104') . "\n";
 496         ld_cmd_children('status');
 497
 498         return 2;
 499     }
 500
 501     print {*STDERR} _message_only('INF0101', $CONFIG_FILE{path}, $oldpid) . "\n";
 502
 503     read_config();
 504     ld_cmd_children('status');
 505
 506     return 0;
 507 }
 508
 509 # cmd_version
 510 # Configuration syntax check
 511 # Called if command argument is configtest
 512 # return: 0 if syntax ok
 513 #         otherwise, exit by read_config
 514 sub cmd_configtest {
 515     read_config();
 516     print {*STDOUT} "Syntax OK\n";
 517     return 0;
 518 }
 519
 520 # cmd_version
 521 # Show program version.
 522 # Called if command argument is version
 523 # return: 0
 524 sub cmd_version {
 525     print {*STDOUT} "l7directord, version $VERSION\n$COPYRIGHT\n";
 526     return 0;
 527 }
 528
 529 # cmd_help
 530 # Show command manual.
 531 # Called if command argument is help
 532 # return: 0
 533 sub cmd_help {
 534     system_wrapper( '/usr/bin/perldoc ' . $PROC_ENV{l7directord} );
 535     return 0;
 536 }
 537
 538 # cmd_usage
 539 # Show command usage.
 540 # Called if command argument is unknown or not specified.
 541 # return: 0
 542 sub cmd_usage {
 543     print {*STDERR}
 544         "Usage: l7directord {start|stop|restart|try-restart|reload|status|configtest}\n"
 545       . "Try `l7directord --help' for more information.\n";
 546     return 0;
 547 }
 548
 549 # set_ld_handler
 550 # Set signal handler function.
 551 sub set_ld_handler {
 552     $SIG{ INT  } = \&ld_handler_term;
 553     $SIG{ QUIT } = \&ld_handler_term;
 554     $SIG{ ILL  } = \&ld_handler_term;
 555     $SIG{ ABRT } = \&ld_handler_term;
 556     $SIG{ FPE  } = \&ld_handler_term;
 557     $SIG{ SEGV } = \&ld_handler_term;
 558     $SIG{ TERM } = \&ld_handler_term;
 559     $SIG{ BUS  } = \&ld_handler_term;
 560     $SIG{ SYS  } = \&ld_handler_term;
 561     $SIG{ XCPU } = \&ld_handler_term;
 562     $SIG{ XFSZ } = \&ld_handler_term;
 563     # HUP is actually used
 564     $SIG{ HUP  } = \&ld_handler_hup;
 565     # This used to call a signal handler, that logged a message
 566     # However, this typically goes to syslog and if syslog
 567     # is playing up a loop will occur.
 568     $SIG{ PIPE } = 'IGNORE';
 569     # handle perl warn signal
 570     $SIG{__WARN__} = \&ld_handler_perl_warn;
 571 }
 572
 573 # ld_handler_perl_warn
 574 # Handle Perl warnings for logging file.
 575 sub ld_handler_perl_warn {
 576     my $warning = join q{, }, @_;
 577     $warning =~ s/[\r\n]//g;
 578     ld_log( _message('WRN0301', $warning) );
 579 }
 580
 581 # read_pid
 582 # Read pid file and check if pid (l7directord) is still running
 583 sub read_pid {
 584     my $old_pid  = undef;
 585     my $file_pid = undef;
 586     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 587     eval {
 588         open my $pid_handle, '<', $pid_file;
 589         $file_pid = <$pid_handle>;
 590         close $pid_handle;
 591         chomp $file_pid;
 592
 593         # Check to make sure this isn't a stale pid file
 594         my $proc_file = "/proc/$file_pid/cmdline";
 595         open my $proc_handle, '<', $proc_file;
 596         my $line = <$proc_handle>;
 597         if ($line =~ /l7directord/) {
 598             $old_pid = $file_pid;
 599         }
 600         close $proc_handle;
 601     };
 602
 603     return wantarray ? ($old_pid, $file_pid) : $old_pid;
 604 }
 605
 606 # write_pid
 607 # Write pid number to pid file.
 608 sub write_pid {
 609     my $pid = shift;
 610
 611     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 612     if (!defined $pid || $pid !~ /^\d+$/ || $pid < 1) {
 613         $pid = defined $pid ? $pid : 'undef';
 614         init_error( _message_only('ERR0412', $pid) );
 615     }
 616     eval {
 617         open my $pid_handle, '>', $pid_file;
 618         print {$pid_handle} $pid . "\n";
 619         close $pid_handle;
 620     };
 621     if ($EVAL_ERROR) {
 622         init_error( _message_only('ERR0409', $pid_file, $EVAL_ERROR) );
 623     }
 624 }
 625
 626 # remove_pid
 627 # Remove pid file.
 628 sub remove_pid {
 629     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 630     ld_rm_file($pid_file);
 631 }
 632
 633 # init_error
 634 # Handle error during initialization and exit.
 635 sub init_error {
 636     my $msg = shift;
 637     if (defined $msg) {
 638         if ($DEBUG_LEVEL == 0) {
 639             print {*STDERR} $msg . "\n";
 640         }
 641         ld_log( _message('ERR0001', $msg) );
 642     }
 643     ld_exit( 4, _message_only('INF0004') );
 644 }
 645
 646 # ld_handler_term
 647 # If we get a sinal then put a halt flag up
 648 sub ld_handler_term {
 649     my $signal = shift;
 650     $PROC_STAT{halt} = defined $signal ? $signal : 'undef';
 651 }
 652
 653 # ld_handler_hup
 654 # If we get a sinal then put a reload flag up
 655 sub ld_handler_hup {
 656     my $signal = shift;
 657     $PROC_STAT{reload} = defined $signal ? $signal : 'undef';
 658 }
 659
 660 # reread_config
 661 # Re-read config, and then re-setup l7vsd and child process.
 662 sub reread_config {
 663     my $old_virtual = defined $CONFIG{virtual} ? [ @{ $CONFIG{virtual} } ]
 664                     :                            []
 665                     ;
 666     my %old_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
 667                        :                            ()
 668                        ;
 669
 670     %CONFIG = %GLOBAL;
 671     $CONFIG{old_virtual} = $old_virtual;
 672
 673     # analyze config and catch format error
 674     eval {
 675         read_config();
 676         ld_setup();
 677         ld_start();
 678     };
 679     if ($EVAL_ERROR) {
 680         my $exception = $EVAL_ERROR;
 681         chomp $exception;
 682         ld_log( _message('ERR0122', $exception) );
 683         $CONFIG{virtual} = [ @{ $CONFIG{old_virtual} } ];
 684         $CONFIG{execute} = \%old_sub_config;
 685     }
 686
 687     my %new_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
 688                        :                            ()
 689                        ;
 690     for my $sub_config ( keys %old_sub_config ) {
 691         if ( exists $new_sub_config{$sub_config} ) {
 692             if ( system_wrapper($PROC_ENV{l7directord} . " $sub_config reload") ) {
 693                  system_wrapper($PROC_ENV{l7directord} . " $sub_config start");
 694             }
 695             delete $new_sub_config{$sub_config};
 696             delete $old_sub_config{$sub_config};
 697         }
 698     }
 699     ld_cmd_children('stop',  \%old_sub_config);
 700     ld_cmd_children('start', \%new_sub_config);
 701 }
 702
 703 # read_config
 704 # Read configuration and parse settings.
 705 sub read_config {
 706     my $line = 0;
 707     my $current_global_name = q{};
 708     my $config_handle;
 709
 710     eval {
 711         open $config_handle, '<', $CONFIG_FILE{path};
 712     };
 713     if ($EVAL_ERROR) {
 714         config_error( 0, 'ERR0407', $CONFIG_FILE{path} );
 715     }
 716
 717     while (my $config_line = <$config_handle>) {
 718         $line++;
 719         chomp $config_line;
 720         $config_line =~ s/#.*//mg; # remove comment (FIXME optimize regex for "foo='#'")
 721         $config_line =~ s/^\t/$SECTION_VIRTUAL_PREFIX/mg; # convert tab to prefix
 722
 723         next if ($config_line =~ /^(?:$SECTION_VIRTUAL_PREFIX)?\s*$/);
 724
 725         # section global
 726         if ($config_line !~ /^$SECTION_VIRTUAL_PREFIX/) {
 727             my ($name, $value) = validate_config($line, $config_line);
 728             $current_global_name = $name;
 729             if ($name eq 'virtual') {
 730                 my %virtual = %VIRTUAL;
 731                 $virtual{server} = $value;
 732                 push @{ $CONFIG{virtual} }, \%virtual;
 733                 _ld_service_resolve(\%virtual, $value->{port});
 734             }
 735             elsif ($name eq 'execute') {
 736                 $CONFIG{execute}{$value} = 1;
 737             }
 738             else {
 739                 $CONFIG{$name} = $value;
 740             }
 741         }
 742         # section virtual
 743         else {
 744             if ($current_global_name ne 'virtual') {
 745                 config_error($line, 'ERR0119', $config_line);
 746             }
 747             my ($name, $value) = validate_config($line, $config_line);
 748             if ($name eq 'real' && defined $value) {
 749                 push @{ $CONFIG{virtual}[-1]{real} }, @$value;
 750             }
 751             elsif (defined $value) {
 752                 $CONFIG{virtual}[-1]{$name} = $value;
 753             }
 754         }
 755     }
 756
 757     eval {
 758         close $config_handle;
 759     };
 760     if ($EVAL_ERROR) {
 761         config_error( 0, 'ERR0408', $CONFIG_FILE{path} );
 762     }
 763
 764     ld_openlog( $CONFIG{logfile} ) if !$PROC_STAT{log_opened};
 765     check_require_module();
 766     undef $CONFIG_FILE{checksum};
 767     undef $CONFIG_FILE{stattime};
 768     check_cfgfile();
 769
 770     $PROC_STAT{initialized} = 1;
 771 }
 772
 773 # validate_config
 774 # Validation check of configuration.
 775 sub validate_config {
 776     my ($line, $config) = @_;
 777     my ($name, $value) = split /\s*=\s*/, $config, 2;
 778     if (defined $value) {
 779         $value =~ s/\s*$//;
 780         $value =~ s/^("|')(.*)\1$/$2/;
 781     }
 782
 783     # section global validate
 784     if ($name !~ /^$SECTION_VIRTUAL_PREFIX/) {
 785         if (!exists $GLOBAL{$name}) {
 786             config_error($line, 'ERR0120', $config);
 787         }
 788         if ($name eq 'virtual') {
 789             $value = ld_gethostservbyname($value, 'tcp');
 790             if (!defined $value) {
 791                 config_error($line, 'ERR0114', $config);
 792             }
 793         }
 794         elsif (    $name eq 'checktimeout'
 795                 || $name eq 'negotiatetimeout'
 796                 || $name eq 'checkinterval'
 797                 || $name eq 'retryinterval'
 798                 || $name eq 'configinterval'
 799                 || $name eq 'checkcount'      ) {
 800             if (!defined $value || $value !~ /^\d+$/ || $value == 0 ) {
 801                 config_error($line, 'ERR0101', $config);
 802             }
 803         }
 804         elsif (    $name eq 'autoreload'
 805                 || $name eq 'quiescent'  ) {
 806             $value = defined $value && $value =~ /^yes$/i ? 1
 807                    : defined $value && $value =~ /^no$/i  ? 0
 808                    :                                     undef
 809                    ;
 810             if (!defined $value) {
 811                 config_error($line, 'ERR0102', $config);
 812             }
 813         }
 814         elsif ($name eq 'fallback') {
 815             my $fallback = parse_fallback($line, $value, $config);
 816             $value = {tcp => $fallback};
 817         }
 818         elsif ($name eq 'callback') {
 819             if (!defined $value || !-f $value || !-x $value) {
 820                 config_error($line, 'ERR0117', $config);
 821             }
 822         }
 823         elsif ($name eq 'execute') {
 824             if (!defined $value || !-f $value) {
 825                 config_error($line, 'ERR0116', $config);
 826             }
 827         }
 828         elsif ($name eq 'logfile') {
 829             if (!defined $value || ld_openlog($value) ) {
 830                 config_error($line, 'ERR0118', $config);
 831             }
 832         }
 833         elsif ($name eq 'supervised') {
 834             $value = 1;
 835         }
 836     }
 837     # section virtual validate
 838     else {
 839         $name =~ s/^$SECTION_VIRTUAL_PREFIX\s*//g;
 840         if (!exists $VIRTUAL{$name}) {
 841             config_error($line, 'ERR0120', $config);
 842         }
 843         if ($name eq 'real') {
 844             $value = parse_real($line, $value, $config);
 845         }
 846         elsif (    $name eq 'request'
 847                 || $name eq 'receive'
 848                 || $name eq 'login'
 849                 || $name eq 'passwd'
 850                 || $name eq 'database'
 851                 || $name eq 'customcheck'
 852                 || $name eq 'virtualhost' ) {
 853             if (!defined $value || $value !~ /^.+$/) {
 854                 config_error($line, 'ERR0103', $config);
 855             }
 856         }
 857         elsif ($name eq 'checktype') {
 858             my $valid_type = qr{custom|connect|negotiate|ping|off|on|\d+};
 859             $value = lc $value;
 860             if (!defined $value || $value !~ /^(?:$valid_type)$/) {
 861                 config_error($line, 'ERR0104', $config);
 862             }
 863             if ($value =~ /^\d+$/ && $value == 0) {
 864                 config_error($line, 'ERR0104', $config);
 865             }
 866         }
 867         elsif (    $name eq 'checktimeout'
 868                 || $name eq 'negotiatetimeout'
 869                 || $name eq 'checkinterval'
 870                 || $name eq 'retryinterval'
 871                 || $name eq 'checkcount'
 872                 || $name eq 'maxconn'         ) {
 873             if (!defined $value || $value !~ /^\d+$/ || ($name ne 'maxconn' && $value == 0) ) {
 874                 config_error($line, 'ERR0101', $config);
 875             }
 876         }
 877         elsif ($name eq 'checkport') {
 878             if (!defined $value || $value !~ /^\d+$/ || $value == 0 || $value > 65535) {
 879                 config_error($line, 'ERR0108', $config);
 880             }
 881         }
 882         elsif ($name eq 'scheduler') {
 883             my $valid_scheduler = qr{lc|rr|wrr};
 884             $value = lc $value;
 885             if (!defined $value || $value !~ /^(?:$valid_scheduler)$/) {
 886                 config_error($line, 'ERR0105', $config);
 887             }
 888         }
 889         elsif ($name eq 'protocol') {
 890             $value = lc $value;
 891             if (!defined $value || $value !~ /^tcp$/) {
 892                 config_error($line, 'ERR0109', $config);
 893             }
 894         }
 895         elsif ($name eq 'service') {
 896             $value = lc $value;
 897             my $valid_service = qr{http|https|ldap|ftp|smtp|pop|imap|nntp|dns|mysql|pgsql|sip|none};
 898             if (!defined $value || $value !~ /^(?:$valid_service)$/) {
 899                 config_error($line, 'ERR0106', $config);
 900             }
 901         }
 902         elsif ($name eq 'httpmethod') {
 903             my $valid_method = qr{GET|HEAD};
 904             $value = uc $value;
 905             if (!defined $value || $value !~ /^(?:$valid_method)$/) {
 906                 config_error($line, 'ERR0110', $config);
 907             }
 908         }
 909         elsif ($name eq 'fallback') {
 910             my $fallback = parse_fallback($line, $value, $config);
 911             $value = {tcp => $fallback};
 912         }
 913         elsif ($name eq 'quiescent') {
 914             $value = defined $value && $value =~ /^yes$/i ? 1
 915                    : defined $value && $value =~ /^no$/i  ? 0
 916                    :                                     undef
 917                    ;
 918             if (!defined $value) {
 919                 config_error($line, 'ERR0102', $config);
 920             }
 921         }
 922         elsif ($name eq 'module') {
 923             my %key_option = ( url         => ['--pattern-match', '--uri-pattern-match', '--host-pattern-match'],
 924                                pfilter     => ['--pattern-match'],
 925                                sessionless => [],
 926                                ip          => [],
 927                                sslid       => [],
 928                              );
 929             my $module = undef;
 930             my $option = undef;
 931             my $key    = q{};
 932             if (defined $value) {
 933                 $value =~ s/["']//g;
 934                 ($module, $option) = split /\s+/, $value, 2;
 935             }
 936             $module = lc $module;
 937             if ( !defined $module || !exists $key_option{$module} ) {
 938                 config_error($line, 'ERR0111', $config);
 939             }
 940             for my $key_opt ( @{$key_option{$module}} ) {
 941                 if (defined $option && $option =~ /$key_opt\s+(\S+)/) {
 942                     $key .= q{ } if $key;
 943                     $key .= $key_opt . q{ } . $1;
 944                 }
 945             }
 946             if ( !$key && @{$key_option{$module}} ) {
 947                 # when omit cookie module key option
 948                 my $key_opt = join q{' or `}, @{$key_option{$module}};
 949                 config_error($line, 'ERR0112', $module, $key_opt, $config);
 950             }
 951             $value = {name => $module, option => $option, key => $key};
 952         }
 953         elsif ($name eq 'sorryserver') {
 954             my $sorry_server = ld_gethostservbyname($value, 'tcp');
 955             if (!defined $sorry_server) {
 956                 config_error($line, 'ERR0114', $config);
 957             }
 958             $value = $sorry_server;
 959         }
 960         elsif (    $name eq 'qosup'
 961                 || $name eq 'qosdown' ) {
 962             $value = uc $value;
 963             if ( !defined $value || ($value ne '0' && $value !~ /^[1-9]\d{0,2}[KMG]$/) ) {
 964                 config_error($line, 'ERR0113', $config);
 965             }
 966         }
 967         elsif (    $name eq 'realdowncallback'
 968                 || $name eq 'realrecovercallback' ) {
 969             if (!defined $value || !-f $value || !-x $value) {
 970                 config_error($line, 'ERR0117', $config);
 971             }
 972         }
 973     }
 974
 975     return ($name, $value);
 976 }
 977
 978 # check_require_module
 979 # Check service setting and require module.
 980 sub check_require_module {
 981     my %require_module = (
 982         http    => [ qw( LWP::UserAgent LWP::Debug ) ],
 983         https   => [ qw( LWP::UserAgent LWP::Debug Crypt::SSLeay ) ],
 984         ftp     => [ qw( Net::FTP ) ],
 985         smtp    => [ qw( Net::SMTP ) ],
 986         pop     => [ qw( Net::POP3 ) ],
 987         imap    => [ qw( Mail::IMAPClient ) ],
 988         ldap    => [ qw( Net::LDAP ) ],
 989         nntp    => [ qw( IO::Socket IO::Select ) ],
 990         dns     => [ qw( Net::DNS ) ],
 991         mysql   => [ qw( DBI DBD::mysql ) ],
 992         pgsql   => [ qw( DBI DBD::Pg ) ],
 993         sip     => [ qw( IO::Socket::INET ) ],
 994         ping    => [ qw( Net::Ping ) ],
 995         connect => [ qw( IO::Socket::INET ) ],
 996     );
 997
 998     for my $v ( @{ $CONFIG{virtual} } ) {
 999         next if !defined $v;
1000         next if ( !defined $v->{service} || !defined $v->{checktype} );
1001         my $check_service = q{};
1002         if ( $v->{checktype} eq 'negotiate' && $require_module{ $v->{service} } ) {
1003             $check_service = $v->{service};
1004         }
1005         elsif ($v->{checktype} eq 'ping' || $v->{checktype} eq 'connect') {
1006             $check_service = $v->{checktype};
1007         }
1008         else {
1009             next;
1010         }
1011         for my $module ( @{ $require_module{$check_service} } ) {
1012             my $module_path = $module . '.pm';
1013             $module_path =~ s{::}{/}g;
1014             eval {
1015                 require $module_path;
1016             };
1017             if ($EVAL_ERROR) {
1018                 config_error(0, 'ERR0123', $module, $check_service);
1019             }
1020         }
1021     }
1022 }
1023
1024 # _ld_service_resolve
1025 # Set service name from port number
1026 # pre: vsrv: Virtual Service to resolve port
1027 #      port: port in the form
1028 # post: If $vsrv->{service} is not set, then set it to "http",
1029 #       "https", "ftp", "smtp", "pop", "imap", "ldap", "nntp" or "none"
1030 #       if $vsrv->{port} is 80, 443, 21, 25, 110, 143, 389 or
1031 #       any other value, respectivley
1032 # return: none
1033 sub _ld_service_resolve {
1034     my ($vsrv, $port) = @_;
1035
1036     my %servname;
1037     my @p = qw( 80   443   21  25   110 119  143  389  53  3306  5432  5060 );
1038     my @s = qw( http https ftp smtp pop nntp imap ldap dns mysql pgsql sip  );
1039     @servname{@p} = @s;
1040
1041     if (defined $vsrv && !defined $vsrv->{service} && defined $port) {
1042         $vsrv->{service} = exists $servname{$port} ? $servname{$port}
1043                          :                           'none'
1044                          ;
1045     }
1046 }
1047
1048 # parse_fallback
1049 # Parse a fallback server
1050 # pre: line: line number fallback server was read from
1051 #      fallback: Should be of the form
1052 #                ip_address|hostname[:port|:service_name] masq
1053 #      config_line: line read from configuration file
1054 # post: fallback is parsed
1055 # return: Reference to hash of the form
1056 #         { server => blah, forward => blah }
1057 #         Debugging message will be reported and programme will exit
1058 #         on error.
1059 sub parse_fallback {
1060     my ($line, $fallback, $config_line) = @_;
1061
1062     if (!defined $fallback || $fallback !~ /^(\S+)(?:\s+(\S+))?$/) {
1063         config_error($line, 'ERR0114', $config_line);
1064     }
1065     my ($ip_port, $forward) = ($1, $2);
1066     $ip_port = ld_gethostservbyname($ip_port, 'tcp');
1067     if ( !defined $ip_port ) {
1068         config_error($line, 'ERR0114', $config_line);
1069     }
1070     if (defined $forward && $forward !~ /^masq$/i) {
1071         config_error($line, 'ERR0107', $config_line);
1072     }
1073
1074     my %fallback = %REAL;
1075     $fallback{server} = $ip_port;
1076     if (defined $forward) {
1077         $fallback{forward} = $forward;
1078     }
1079
1080     return \%fallback;
1081 }
1082
1083 # parse_real
1084 # Parse a real server
1085 # pre: line: line number real server was read from
1086 #      real: Should be of the form
1087 #                ip_address|hostname[:port|:service_name] masq
1088 #      config_line: line read from configuration file
1089 # post: real is parsed
1090 # return: Reference to array include real server hash reference
1091 #         [ {server...}, {server...} ... ]
1092 #         Debugging message will be reported and programme will exit
1093 #         on error.
1094 sub parse_real {
1095     my ($line, $real, $config_line) = @_;
1096
1097     my $ip_host = qr{\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+};
1098     my $port_service = qr{\d+|[a-z0-9-]+};
1099     if (    !defined $real
1100          || $real !~ /^
1101                       ($ip_host)             # ip or host
1102                       (?:->($ip_host))?      # range (optional)
1103                       (?::($port_service))?  # port or service (optional)
1104                       (?:\s+([a-z]+))?       # forwarding mode (optional)
1105                       (?:\s+(\d+))?          # weight (optional)
1106                       (?:\s+
1107                          ([^,\s]+)           # "request
1108                          \s*[ ,]\s*          #  separater
1109                          (\S+)               #  receive"
1110                       )?                     # (optional)
1111                       $/ix) {
1112         config_error($line, 'ERR0114', $config_line);
1113     }
1114     my ($ip1, $ip2, $port, $forward, $weight, $request, $receive)
1115      = (  $1,   $2,    $3,       $4,      $5,       $6,       $7);
1116
1117     # set forward, weight and request-receive pair.
1118     my %real = %REAL;
1119     if (defined $forward) {
1120         $forward = lc $forward;
1121         if ($forward !~ /^masq$/) {
1122             config_error($line, 'ERR0107', $config_line);
1123         }
1124         $real{forward} = $forward;
1125     }
1126     if (defined $weight) {
1127         $real{weight} = $weight;
1128     }
1129     if (defined $request && defined $receive) {
1130         $request =~ s/^\s*("|')(.*)\1\s*/$2/;
1131         $receive =~ s/^\s*("|')(.*)\1\s*/$2/;
1132         $real{request} = $request;
1133         $real{receive} = $receive;
1134     }
1135
1136     my $resolved_port = undef;
1137     if (defined $port) {
1138         $resolved_port = ld_getservbyname($port);
1139         if (!defined $resolved_port) {
1140             config_error($line, 'ERR0108', $config_line);
1141         }
1142     }
1143
1144     my $resolved_ip1 = ld_gethostbyname($ip1);
1145     if (!defined $resolved_ip1) {
1146         config_error($line, 'ERR0114', $config_line);
1147     }
1148
1149     my $resolved_ip2 = $resolved_ip1;
1150     if (defined $ip2) {
1151         $resolved_ip2 = ld_gethostbyname($ip2);
1152         if (!defined $resolved_ip2) {
1153             config_error($line, 'ERR0114', $config_line);
1154         }
1155     }
1156
1157     my $int_ip1 = ip_to_int($resolved_ip1);
1158     my $int_ip2 = ip_to_int($resolved_ip2);
1159     if ($int_ip1 > $int_ip2) {
1160         config_error($line, 'ERR0115', $resolved_ip1, $resolved_ip2, $config_line);
1161     }
1162
1163     my @reals = ();
1164     for (my $int_ip = $int_ip1; $int_ip <= $int_ip2; $int_ip++) {
1165         my %new_real = %real;
1166         $new_real{server}{ip  } = int_to_ip($int_ip);
1167         $new_real{server}{port} = $resolved_port;
1168         push @reals, \%new_real;
1169     }
1170     return \@reals;
1171 }
1172
1173 # config_error
1174 # Handle error during read configuration and validation check
1175 sub config_error {
1176     my ($line, $msg_code, @msg_args) = @_;
1177
1178     if ($DEBUG_LEVEL > 0 || $PROC_STAT{initialized} == 0) {
1179         my $msg = _message_only($msg_code, @msg_args);
1180         if (defined $line && $line > 0) {
1181             print {*STDERR} _message_only('ERR0121', $CONFIG_FILE{path}, $line, $msg) . "\n";
1182         }
1183         else {
1184             print {*STDERR} $msg . "\n";
1185         }
1186     }
1187     else {
1188         if ($line > 0) {
1189             ld_log( _message('ERR0121', $CONFIG_FILE{path}, $line, q{}) );
1190         }
1191         ld_log( _message($msg_code, @msg_args) );
1192     }
1193     if ( $PROC_STAT{initialized} == 0 ) {
1194         ld_exit(5, _message_only('ERR0002') );
1195     }
1196     else {
1197         die "Configuration error.\n";
1198     }
1199 }
1200
1201 # ld_setup
1202 # Check configuration value and set default value, overwrite global config value and so on.
1203 sub ld_setup {
1204     if ( defined $CONFIG{virtual} ) {
1205         for my $v ( @{ $CONFIG{virtual} } ) {
1206             next if !defined $v;
1207             if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
1208                 $v->{option}{protocol} = "-t";
1209             }
1210
1211             if ( defined $v->{option} && defined $v->{option}{protocol} && defined $v->{module} && defined $v->{module}{name} ) {
1212                 my $module_option = $v->{module}{name};
1213                 if ( defined $v->{module}{option} ) {
1214                     $module_option .= q{ } . $v->{module}{option};
1215                 }
1216                 $v->{option}{main} = sprintf "%s %s -m %s", $v->{option}{protocol}, get_ip_port($v), $module_option;
1217                 $v->{option}{flags} = $v->{option}{main};
1218                 if ( defined $v->{scheduler} ) {
1219                     $v->{option}{flags} .= ' -s ' . $v->{scheduler};
1220                 }
1221                 if ( defined $v->{maxconn} ) {
1222                     $v->{option}{flags} .= ' -u ' . $v->{maxconn};
1223                 }
1224                 if ( defined $v->{sorryserver} && defined $v->{sorryserver}{ip} && defined $v->{sorryserver}{port} ) {
1225                     $v->{option}{flags} .= ' -b ' . $v->{sorryserver}{ip} . ':' . $v->{sorryserver}{port};
1226                 }
1227                 if ( defined $v->{qosup} ) {
1228                     $v->{option}{flags} .= ' -Q ' . $v->{qosup};
1229                 }
1230                 if ( defined $v->{qosdown} ) {
1231                     $v->{option}{flags} .= ' -q ' . $v->{qosdown};
1232                 }
1233             }
1234
1235             if ( !defined $v->{fallback} && defined $CONFIG{fallback} ) {
1236                 $v->{fallback} = { %{ $CONFIG{fallback} } };
1237             }
1238             if ( defined $v->{fallback} ) {
1239                 for my $proto ( keys %{ $v->{fallback} } ) {
1240                     $v->{fallback}{$proto}{option}{flags} = '-r ' . get_ip_port( $v->{fallback}{$proto} );
1241                 }
1242             }
1243             if (defined $v->{checktype} && $v->{checktype} =~ /^\d+$/) {
1244                 $v->{num_connects} = $v->{checktype};
1245                 $v->{checktype} = 'combined';
1246             }
1247
1248             if ( defined $v->{login} && $v->{login} eq q{} ) {
1249                 $v->{login} = defined $v->{service} && $v->{service} eq 'ftp' ? 'anonymous'
1250                             : defined $v->{service} && $v->{service} eq 'sip' ? 'l7directord@' . $PROC_ENV{hostname}
1251                             :                                                   q{}
1252                             ;
1253             }
1254             if ( defined $v->{passwd} && $v->{passwd} eq q{} ) {
1255                 $v->{passwd} = defined $v->{service} && $v->{service} eq 'ftp' ? 'l7directord@' . $PROC_ENV{hostname}
1256                              :                                                   q{}
1257                              ;
1258             }
1259
1260             if ( defined $v->{real} ) {
1261                 for my $r ( @{ $v->{real} } ) {
1262                     next if !defined $r;
1263                     if ( defined $r->{forward} ) {
1264                         $r->{option}{forward} = get_forward_flag( $r->{forward} );
1265                     }
1266                     if ( !defined $r->{weight} || $r->{weight} !~ /^\d+$/ ) {
1267                         $r->{weight} = 1;
1268                     }
1269
1270                     if ( !defined $r->{server}{port} ) {
1271                         $r->{server}{port} = $v->{server}{port};
1272                     }
1273
1274                     $r->{option}{flags} = '-r ' . get_ip_port($r);
1275
1276                     # build request URL
1277                     if ( defined $v->{service} && defined $r->{server} ) {
1278                         my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
1279                         $r->{url} = sprintf "%s://%s:%s/",
1280                                             $v->{service}, $r->{server}{ip}, $port;
1281                     }
1282                     if ( !defined $r->{request} && defined $v->{request} ) {
1283                         $r->{request} = $v->{request};
1284                     }
1285                     if ( !defined $r->{receive} && defined $v->{receive} ) {
1286                         $r->{receive} = $v->{receive};
1287                     }
1288                     if ( defined $r->{request} ) {
1289                         my $uri = $r->{request};
1290                         my $service = $v->{service};
1291                         if ( defined $v->{service} && $uri =~ m{^$service://} ) {
1292                             $r->{url} = $uri;
1293                         }
1294                         else {
1295                             $uri =~ s{^/+}{}g;
1296                             $r->{url} .= $uri;
1297                         }
1298                     }
1299
1300                     # set connect count for combine check
1301                     if (defined $v->{checktype} && $v->{checktype} eq 'combined') {
1302                         $r->{num_connects} = undef;
1303                     }
1304
1305                     $r->{fail_counts} = 0;
1306                     $r->{healthchecked} = 0;
1307                 }
1308             }
1309             if ( !defined $v->{checkcount} || $v->{checkcount} <= 0 ) {
1310                 $v->{checkcount} = $CONFIG{checkcount};
1311             }
1312             if ( !defined $v->{checktimeout} || $v->{checktimeout} <= 0 ) {
1313                 $v->{checktimeout} = $CONFIG{checktimeout};
1314             }
1315             if ( !defined $v->{negotiatetimeout} || $v->{negotiatetimeout} <= 0 ) {
1316                 $v->{negotiatetimeout} = $CONFIG{negotiatetimeout};
1317             }
1318             if ( !defined $v->{checkinterval} || $v->{checkinterval} <= 0 ) {
1319                 $v->{checkinterval} = $CONFIG{checkinterval};
1320             }
1321             if ( !defined $v->{retryinterval} || $v->{retryinterval} <= 0 ) {
1322                 $v->{retryinterval} = $CONFIG{retryinterval};
1323             }
1324             if ( !defined $v->{quiescent} ) {
1325                 $v->{quiescent} = $CONFIG{quiescent};
1326             }
1327         }
1328     }
1329
1330     if (defined $CONFIG{fallback}) {
1331         $CONFIG{fallback}{tcp}{option}{flags} = '-r ' . get_ip_port( $CONFIG{fallback}{tcp} );
1332     }
1333 }
1334
1335 # Removed persistent and netmask related hash entries from the structure of l7vsadm since it is not used - NTT COMWARE
1336 # ld_read_l7vsadm
1337 # Parses the output of "l7vsadm -K -n" and puts into a structure of
1338 # the following from:
1339 #
1340 # {
1341 #   (vip_address:vport) protocol module_name module_key_value => {
1342 #     "scheduler" => scheduler,
1343 #     "real" => {
1344 #       rip_address:rport => {
1345 #         "forward" => forwarding_mechanism,
1346 #         "weight"  => weight
1347 #       },
1348 #       ...
1349 #     }
1350 #   },
1351 #   ...
1352 # }
1353 #
1354 # where:
1355 #   vip_address: IP address of virtual service
1356 #   vport: Port of virtual service
1357 #   module_name: Depicts the name of the module (For example, pfilter)
1358 #   module_key_value: Depicts the module key values (For example, --path-match xxxx)
1359 #   scheduler: Scheduler for virtual service
1360 #
1361 #   rip_address: IP address of real server
1362 #   rport: Port of real server
1363 #   forwarding_mechanism: Forwarding mechanism for real server. This would be only masq.
1364 #   weight: Weight of real server
1365 #
1366 # pre: none
1367 # post: l7vsadm -K -n is parsed
1368 # result: reference to structure detailed above.
1369 sub ld_read_l7vsadm {
1370     my $current_service = {};
1371     my $vip_id;
1372
1373     if ( !-f $PROC_ENV{l7vsadm} || !-x $PROC_ENV{l7vsadm} ) {
1374         ld_log( _message( 'FTL0101', $PROC_ENV{l7vsadm} ) );
1375         return $current_service;
1376     }
1377     # read status of current l7vsadm -K -n
1378     # -K indicates Key parameters of the module included.
1379     my $list_command = $PROC_ENV{l7vsadm} . " -K -n";
1380     my $cmd_result = qx{$list_command};
1381     my @list_line = split /\n/, $cmd_result;
1382
1383     # skip below header
1384     # [cf] Layer-7 Virtual Server version 2.0.0-0
1385     # [cf] Prot LocalAddress:Port ProtoMod Scheduler Reschedule Protomod_key_string
1386     # [cf]   -> RemoteAddress:Port           Forward Weight ActiveConn InactConn
1387     shift @list_line; shift @list_line; shift @list_line;
1388
1389     for my $line (@list_line) {
1390         # check virtual service line format
1391         # [cf] TCP 192.168.0.4:12121 cinsert rr 0 --cookie-name CookieName
1392         if ($line =~ /
1393                 ^           # top
1394                 (\w+) \s+   # 'TCP'
1395                 (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}) \s+ # ip port
1396                 (\w+) \s+   # protocol module
1397                 \w+ \s+     # scheduler
1398                 (?:0|1) \s+ # reschedule flag
1399                 (.*)        # module key
1400                 $           # end
1401                 /x
1402             ) {
1403             my ($proto, $ip_port, $module, $key) = ($1, $2, $3, $4);
1404             # vip_id MUST be same format as get_virtual_id_str
1405             $proto = lc $proto;
1406             $vip_id = "$proto:$ip_port:$module $key";
1407             $vip_id =~ s/\s+$//;
1408             $current_service->{$vip_id} = undef;
1409             next;
1410         }
1411         # check real server line format
1412         # [cf] -> 192.168.0.4:7780             Masq    1     10     123456
1413         if (defined $vip_id && $line =~ /
1414                 ^           # top
1415                 \s+ -> \s+  # arrow
1416                 (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}):(\d{1,5}) \s+ # ip port
1417                 (\w+) \s+   # 'Masq'
1418                 (\d+) \s+   # weight
1419                 \d+ \s+     # active connections
1420                 \d+ \s*     # inactive connections
1421                 $           # end
1422                 /x
1423             ) {
1424             my ($ip, $port, $forward, $weight) = ($1, $2, $3, $4);
1425             my $ip_port = "$ip:$port";
1426             my $real = {
1427                     server  => { ip => $ip, port => $port },
1428                     weight  => $weight,
1429                     forward => $forward,
1430                     option  => {
1431                                 flags   => "-r $ip_port",
1432                                 forward => get_forward_flag($forward),
1433                                 },
1434             };
1435             $current_service->{$vip_id}{$ip_port} = $real;
1436         }
1437     }
1438
1439     return $current_service;
1440 }
1441
1442 # ld_operate_virtual
1443 # Operate virtual service on l7vsd by l7vsadm command.
1444 sub ld_operate_virtual {
1445     my ($v, $option, $success_code, $error_code) = @_;
1446     if (!defined $v || !defined $option || !defined $success_code || !defined $error_code) {
1447         ld_log( _message('ERR0501') );
1448         return;
1449     }
1450
1451     my $command = $PROC_ENV{l7vsadm} . " $option ";
1452     if ($option ne '-D') {
1453         $command .= $v->{option}{flags};
1454     }
1455     else {
1456         $command .= $v->{option}{main};
1457     }
1458     $command .= ' 2>&1';
1459
1460     my ($result, $output) = command_wrapper($command);
1461
1462     my $module_key = $v->{module}{name};
1463     if ( defined $v->{module}{key} ) {
1464         $module_key .= q{ } . $v->{module}{key};
1465     }
1466     if ($result == 0) {
1467         ld_log( _message($success_code, get_ip_port($v), $module_key) );
1468     }
1469     else {
1470         ($output) = split /\n/, $output, 2;
1471         ld_log( _message($error_code, get_ip_port($v), $module_key, $output) );
1472     }
1473 }
1474
1475 # ld_add_virtual
1476 # Call operate virtual with add option.
1477 sub ld_add_virtual {
1478     my $v = shift;
1479     ld_operate_virtual($v, '-A', 'INF0201', 'ERR0201');
1480 }
1481
1482 # ld_edit_virtual
1483 # Call operate virtual with edit option.
1484 sub ld_edit_virtual {
1485     my $v = shift;
1486     ld_operate_virtual($v, '-E', 'INF0202', 'ERR0202');
1487 }
1488
1489 # ld_delete_virtual
1490 # Call operate virtual with delete option.
1491 sub ld_delete_virtual {
1492     my $v = shift;
1493     ld_operate_virtual($v, '-D', 'INF0203', 'ERR0203');
1494 }
1495
1496 # ld_operate_real
1497 # Operate real server on l7vsd by l7vsadm command.
1498 sub ld_operate_real {
1499     my ($v, $r, $weight, $option, $success_code, $error_code) = @_;
1500     if (!defined $v || !defined $r || !defined $option || !defined $success_code || !defined $error_code) {
1501         ld_log( _message('ERR0501') );
1502         return;
1503     }
1504
1505     my $command
1506         = $PROC_ENV{l7vsadm} . " $option " . $v->{option}{main} . q{ } . $r->{option}{flags};
1507
1508     # replace weight value
1509     if (defined $weight) {
1510         $command .= ' -w ' . $weight;
1511     }
1512     $command .= ' 2>&1';
1513
1514     my ($result, $output) = command_wrapper($command);
1515
1516     my $module_key = $v->{module}{name};
1517     if ( defined $v->{module}{key} ) {
1518         $module_key .= q{ } . $v->{module}{key};
1519     }
1520     if ($result == 0) {
1521         ld_log( _message($success_code, get_ip_port($r), get_ip_port($v), $module_key, $weight) );
1522     }
1523     else {
1524         ($output) = split /\n/, $output, 2;
1525         ld_log( _message($error_code, get_ip_port($r), get_ip_port($v), $module_key, $output) );
1526     }
1527 }
1528
1529 # ld_add_real
1530 # Call operate real with add option.
1531 sub ld_add_real {
1532     my ($v, $r, $weight) = @_;
1533     ld_operate_real($v, $r, $weight, '-a', 'INF0204', 'ERR0204');
1534 }
1535
1536 # ld_edit_real
1537 # Call operate real with edit option.
1538 sub ld_edit_real {
1539     my ($v, $r, $weight) = @_;
1540     ld_operate_real($v, $r, $weight, '-e', 'INF0205', 'ERR0205');
1541 }
1542
1543 # ld_delete_real
1544 # Call operate real with delete option.
1545 sub ld_delete_real {
1546     my ($v, $r) = @_;
1547     ld_operate_real($v, $r, undef, '-d', 'INF0206', 'ERR0206');
1548 }
1549
1550 # ld_start
1551 # Check l7vsd by l7vsadm command and create virtual service on l7vsd.
1552 sub ld_start {
1553     # read status of current l7vsadm -K -n
1554     my $current_service = ld_read_l7vsadm();
1555     if (!defined $current_service) {
1556         ld_log( _message('FTL0201') );
1557         return;
1558     }
1559
1560     my %old_health_check = %HEALTH_CHECK;
1561     %HEALTH_CHECK = ();
1562
1563     # make sure virtual servers are up to date
1564     if ( defined $CONFIG{virtual} ) {
1565         for my $nv ( @{ $CONFIG{virtual} } ) {
1566             my $vip_id = get_virtual_id_str($nv);
1567             if (!defined $vip_id) {
1568                 ld_log( _message('ERR0502') );
1569                 return;
1570             }
1571
1572             if ( exists( $current_service->{$vip_id} ) ) {
1573                 # service already exists, modify it
1574                 ld_edit_virtual($nv);
1575             }
1576             else {
1577                 # no such service, create a new one
1578                 ld_add_virtual($nv);
1579             }
1580
1581             my $or = $current_service->{$vip_id} || {};
1582
1583             # Not delete fallback server from l7vsd if exist
1584             my $fallback = fallback_find($nv);
1585             if (defined $fallback) {
1586                 my $fallback_ip_port = get_ip_port( $fallback->{ $nv->{protocol} } );
1587                 delete $or->{$fallback_ip_port};
1588                 fallback_on($nv);
1589             }
1590
1591             if ( defined $nv->{real} ) {
1592                 CHECK_REAL:
1593                 for my $nr ( @{ $nv->{real} } ) {
1594                     delete $or->{ get_ip_port($nr) };
1595
1596                     my $health_check_id = get_health_check_id_str($nv, $nr);
1597                     if (!defined $health_check_id) {
1598                         ld_log( _message('ERR0503') );
1599                         return;
1600                     }
1601
1602                     # search same health check process
1603                     if ( exists $HEALTH_CHECK{$health_check_id} ) {
1604                         # same health check process exist
1605                         # then check real server and virtual service ($r, $v)
1606                         for my $v_r_pair ( @{ $HEALTH_CHECK{$health_check_id}{manage} } ) {
1607                             # completely same. check next real server
1608                             next CHECK_REAL if ($nv eq $v_r_pair->[0] && $nr eq $v_r_pair->[1]);
1609                         }
1610
1611                         # add real server and virtual service to management list
1612                         push @{ $HEALTH_CHECK{$health_check_id}{manage} }, [$nv, $nr];
1613                     }
1614                     else {
1615                         # add to health check process list
1616                         $HEALTH_CHECK{$health_check_id}{manage} = [ [$nv, $nr] ];
1617                     }
1618                 }
1619             }
1620
1621             # remove remaining entries for real servers
1622             for my $remove_real_ip_port (keys %$or) {
1623                 ld_delete_real( $nv, $or->{$remove_real_ip_port} );
1624                 delete $or->{$remove_real_ip_port};
1625             }
1626
1627             delete $current_service->{$vip_id};
1628         }
1629     }
1630
1631     # terminate old health check process
1632     # TODO should compare old and new, and only if different then re-create process...
1633     for my $id (keys %old_health_check) {
1634         # kill old health check process
1635         if ( defined $old_health_check{$id}{pid} ) {
1636             # TODO cannot kill process during pinging to unreachable host?
1637             {
1638                 local $SIG{ALRM} = sub { die; };
1639                 kill 15, $old_health_check{$id}{pid};
1640                 eval {
1641                     alarm 3;
1642                     waitpid $old_health_check{$id}{pid}, 0;
1643                     alarm 0;
1644                 };
1645                 alarm 0;
1646                 if ($EVAL_ERROR) {
1647                     kill 9, $old_health_check{$id}{pid};
1648                     waitpid $old_health_check{$id}{pid}, WNOHANG;
1649                 }
1650             }
1651         }
1652     }
1653
1654     # remove remaining entries for virtual servers
1655     if ( defined $CONFIG{old_virtual} ) {
1656         for my $nv ( @{ $CONFIG{old_virtual} } ) {
1657             my $vip_id = get_virtual_id_str($nv);
1658             if ( exists $current_service->{$vip_id} ) {
1659                 # service still exists, remove it
1660                 ld_delete_virtual($nv);
1661             }
1662         }
1663     }
1664     delete $CONFIG{old_virtual};
1665 }
1666
1667 # ld_cmd_children
1668 # Run l7directord command to child process.
1669 # Child process is not health check process,
1670 # but sub config (specified by configuration with `execute') process.
1671 sub ld_cmd_children {
1672     my $command_type = shift;
1673     my $execute = shift;
1674
1675     # instantiate other l7directord, if specified
1676     if (!defined $execute) {
1677         if ( defined $CONFIG{execute} ) {
1678             for my $sub_config ( keys %{ $CONFIG{execute} } ) {
1679                 if (defined $command_type && defined $sub_config) {
1680                     my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
1681                     system_wrapper($command);
1682                 }
1683             }
1684         }
1685     }
1686     else {
1687         for my $sub_config ( keys %$execute ) {
1688             if (defined $command_type && defined $sub_config) {
1689                 my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
1690                 system_wrapper($command);
1691             }
1692         }
1693     }
1694 }
1695
1696 # ld_stop
1697 # Remove virtual service for stopping this program.
1698 sub ld_stop {
1699     my $srv = ld_read_l7vsadm();
1700     if (!defined $srv) {
1701         ld_log( _message('FTL0201') );
1702         return;
1703     }
1704     if ( defined $CONFIG{virtual} ) {
1705         for my $v ( @{ $CONFIG{virtual} } ) {
1706             my $vid = get_virtual_id_str($v);
1707             if (!defined $vid) {
1708                 ld_log( _message('ERR0502') );
1709                 return;
1710             }
1711             if ( exists $srv->{$vid} ) {
1712                 for my $rid ( keys %{ $srv->{$vid} } ) {
1713                     ld_delete_real( $v, $srv->{$vid}{$rid} );
1714                 }
1715             }
1716             ld_delete_virtual($v);
1717         }
1718     }
1719 }
1720
1721 # ld_main
1722 # Main function of this program.
1723 # Create virtual service and loop below 3 steps.
1724 # 1. Check health check sub process and (re-)create sub process as needed
1725 # 2. Check signal in sleep and start to terminate program or reload config as needed
1726 # 3. Check config file and reload config as needed
1727 sub ld_main {
1728     ld_start();
1729
1730     # Main failover checking code
1731     MAIN_LOOP:
1732     while (1) {
1733         # manage real server check process.
1734         REAL_CHECK:
1735         while (1) {
1736             my @id_lists = check_child_process();
1737             # if child process is not running
1738             if (@id_lists) {
1739                 create_check_process(@id_lists);
1740             }
1741             my $signal = sleep_and_check_signal( $CONFIG{configinterval} );
1742             last MAIN_LOOP  if defined $signal && $signal eq 'halt';
1743             last REAL_CHECK if defined $signal && $signal eq 'reload';
1744             last REAL_CHECK if check_cfgfile();
1745         }
1746
1747         # reload config
1748         reread_config();
1749     }
1750
1751     # signal TERM to child process
1752     for my $id (keys %HEALTH_CHECK) {
1753         if ( defined $HEALTH_CHECK{$id}{pid} ) {
1754             # TODO cannot kill process during pinging to unreachable host?
1755             {
1756                 local $SIG{ALRM} = sub { die; };
1757                 kill 15, $HEALTH_CHECK{$id}{pid};
1758                 eval {
1759                     alarm 3;
1760                     waitpid $HEALTH_CHECK{$id}{pid}, 0;
1761                     alarm 0;
1762                 };
1763                 alarm 0;
1764                 if ($EVAL_ERROR) {
1765                     kill 9, $HEALTH_CHECK{$id}{pid};
1766                     waitpid $HEALTH_CHECK{$id}{pid}, WNOHANG;
1767                 }
1768             }
1769         }
1770     }
1771     ld_stop();
1772 }
1773
1774 # check_child_process
1775 # Check health check process by signal zero.
1776 # return: Health check id list that (re-)created later.
1777 sub check_child_process {
1778     my @down_process_ids = ();
1779     for my $id (sort keys %HEALTH_CHECK) {
1780         if ( !defined $HEALTH_CHECK{$id}{pid} ) {
1781             # not create ever
1782             ld_log( _message('INF0401', $id) );
1783             push @down_process_ids, $id;
1784             next;
1785         }
1786         # signal 0
1787         my $signaled = kill 0, $HEALTH_CHECK{$id}{pid};
1788         if ($signaled != 1) {
1789             # maybe killed from outside
1790             ld_log( _message('ERR0603', $HEALTH_CHECK{$id}{pid}, $id) );
1791             push @down_process_ids, $id;
1792             next;
1793         }
1794     }
1795     return @down_process_ids;
1796 }
1797
1798 # create_check_process
1799 # Fork health check sub process.
1800 # And health check sub process run health_check sub function.
1801 sub create_check_process {
1802     my @id_lists = @_;
1803     for my $health_check_id (@id_lists) {
1804         my $pid = fork();
1805         if ($pid > 0) {
1806             ld_log( _message('INF0402', $pid, $health_check_id) );
1807             $HEALTH_CHECK{$health_check_id}{pid} = $pid;
1808         }
1809         elsif ($pid == 0) {
1810             $PROC_STAT{parent_pid} = $PROC_STAT{pid};
1811             $PROC_STAT{pid} = $PID;
1812             health_check( $HEALTH_CHECK{$health_check_id}{manage} );
1813         }
1814         else {
1815             ld_log( _message('ERR0604', $health_check_id) );
1816         }
1817         sleep 1;
1818     }
1819 }
1820
1821 # health_check
1822 # Main function of health check process.
1823 # Loop below.
1824 # 1. Health check.
1825 # 2. Status change and reflect to l7vsd as needed.
1826 # 3. Check signal in sleep.
1827 # pre: v_r_list: reference list of virtual service and real server pair
1828 #     $v_r_list = [ [$virtual, $real], [$virtual, $real], ... ];
1829 # return: none
1830 #         MUST use POSIX::_exit when terminate sub process.
1831 sub health_check {
1832     my $v_r_list = shift;
1833     if (!defined $v_r_list) {
1834         ld_log( _message('ERR0501') );
1835         ld_log( _message('FTL0001') );
1836         POSIX::_exit(1);
1837     }
1838
1839     # you can use any virtual, real pair in $v_r_list.
1840     my ($v, $r) = @{ $v_r_list->[0] };
1841     if (!defined $v || !defined $r) {
1842         ld_log( _message('FTL0002') );
1843         POSIX::_exit(2);
1844     }
1845
1846     my $health_check_func = get_check_func($v);
1847     my $current_status = get_status($v_r_list);
1848
1849     my $status = 'STARTING';
1850     my $type = $v->{checktype} eq 'negotiate' ? $v->{service}
1851              : $v->{checktype} eq 'combined'  ? $v->{service} . '(combined)'
1852              :                                  $v->{checktype}
1853              ;
1854     $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;
1855
1856     while (1) {
1857         # health check
1858         my $service_status = &$health_check_func($v, $r);
1859
1860         if ($service_status == $SERVICE_DOWN) {
1861             if (!defined $current_status || $current_status == $SERVICE_UP) {
1862                 $r->{fail_counts}++;
1863                 undef $r->{num_connects};
1864                 if ($r->{fail_counts} >= $v->{checkcount}) {
1865                     ld_log( _message( 'ERR0602', get_ip_port($r) ) );
1866                     service_set($v_r_list, 'down');
1867                     $current_status = $SERVICE_DOWN;
1868                     $status = 'DOWN';
1869                     $r->{fail_counts} = 0;
1870                 }
1871                 else {
1872                     ld_log( _message( 'WRN1001', get_ip_port($r), $v->{checkcount} - $r->{fail_counts} ) );
1873                     $status = sprintf "NG[%d/%d]", $r->{fail_counts}, $v->{checkcount};
1874                 }
1875             }
1876         }
1877         if ($service_status == $SERVICE_UP) {
1878             $r->{fail_counts} = 0;
1879             if (!defined $current_status || $current_status == $SERVICE_DOWN) {
1880                 ld_log( _message( 'ERR0601', get_ip_port($r) ) );
1881                 service_set($v_r_list, 'up');
1882                 $current_status = $SERVICE_UP;
1883             }
1884             $status = 'UP';
1885         }
1886
1887         $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;
1888
1889         my $sleeptime = $r->{fail_counts} ? $v->{retryinterval} : $v->{checkinterval};
1890         last if (sleep_and_check_signal($sleeptime, 1) eq 'halt');
1891
1892         my $parent_process = kill 0, $PROC_STAT{parent_pid};
1893         if ($parent_process != 1) {
1894             ld_log( _message( 'FTL0003', $PROC_STAT{parent_pid} ) );
1895             POSIX::_exit(3);
1896         }
1897     }
1898
1899     ld_log( _message('INF0007') );
1900     POSIX::_exit(0);
1901 }
1902
1903 # sleep_and_check_signal
1904 # Check signal flag each 0.1 secound with sleeping specified seconds.
1905 sub sleep_and_check_signal {
1906     my ($sec, $is_child) = @_;
1907     if (!defined $sec || $sec !~ /^\d+$/) {
1908         ld_log( _message('ERR0501') );
1909         return 'halt';
1910     }
1911
1912     my $sleeped = 0;
1913     while ($sec > $sleeped) {
1914         # non-blocking wait for zombie process
1915         waitpid(-1, WNOHANG); # TODO should move to sigchld handler?
1916
1917         if ($is_child) {
1918             if ( defined $PROC_STAT{halt} ) {
1919                 ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
1920                 return 'halt';
1921             }
1922         }
1923         else {
1924             if ( defined $PROC_STAT{halt} ) {
1925                 ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
1926                 return 'halt';
1927             }
1928             if ( defined $PROC_STAT{reload} ) {
1929                 ld_log( _message( 'WRN0002', $CONFIG_FILE{path}, $PROC_STAT{reload} ) );
1930                 undef $PROC_STAT{reload};
1931                 return 'reload';
1932             }
1933         }
1934         sleep 0.1;
1935         $sleeped += 0.1;
1936     }
1937     return 'run';
1938 }
1939
1940 # get_check_func
1941 # Determine check function by checktype and service.
1942 sub get_check_func {
1943     my $v = shift;
1944     if (!defined $v) {
1945         ld_log( _message('ERR0501') );
1946         return \&check_off;
1947     }
1948
1949     my $type = $v->{checktype};
1950     my $service_func = {
1951         http  => \&check_http,
1952         https => \&check_http,
1953         pop   => \&check_pop,
1954         imap  => \&check_imap,
1955         smtp  => \&check_smtp,
1956         ftp   => \&check_ftp,
1957         ldap  => \&check_ldap,
1958         nntp  => \&check_nntp,
1959         dns   => \&check_dns,
1960         sip   => \&check_sip,
1961         mysql => \&check_mysql,
1962         pgsql => \&check_pgsql,
1963     };
1964
1965     if ( defined $type && ($type eq 'negotiate' || $type eq 'combined') ) {
1966         if (defined $v->{service} && exists $service_func->{ $v->{service} } ) {
1967             my $negotiate_func = $service_func->{ $v->{service} };
1968             if ($type eq 'negotiate') {
1969                 return $negotiate_func;
1970             }
1971             elsif ($type eq 'combined') {
1972                 my $combined_func =  make_combined_func($negotiate_func);
1973                 return $combined_func;
1974             }
1975         }
1976         else {
1977             return \&check_none;
1978         }
1979     }
1980
1981     if (defined $type && $type eq 'custom') {
1982         my $custom_func = make_custom_func( $v->{customcheck} );
1983         return $custom_func;
1984     }
1985
1986     if (defined $type && $type eq 'connect') {
1987         if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
1988             return \&check_connect;
1989         }
1990         else {
1991             return \&check_ping;
1992         }
1993     }
1994
1995     if (defined $type && $type eq 'ping') {
1996         return \&check_ping;
1997     }
1998
1999     if (defined $type && $type eq 'off') {
2000         return \&check_off;
2001     }
2002
2003     if (defined $type && $type eq 'on') {
2004         return \&check_on;
2005     }
2006
2007     return \&check_none;
2008 }
2009
2010 # make_combined_func
2011 # Create combined function.
2012 sub make_combined_func {
2013     my $negotiate_func = shift;
2014     if (!defined $negotiate_func) {
2015         ld_log( _message('ERR0504') );
2016         return \&check_connect;
2017     }
2018
2019     # closure
2020     my $combined_func = sub {
2021         my ($v, $r) = @_;
2022         my $timing    = $v->{num_connects};
2023         my $connected = $r->{num_connects};
2024
2025         if (!defined $connected ||
2026             (defined $timing && $timing <= $connected) ) {
2027             $r->{num_connects} = 0;
2028             return &$negotiate_func($v, $r);
2029         }
2030         else {
2031             $r->{num_connects}++;
2032             return check_connect($v, $r);
2033         }
2034     };
2035
2036     return $combined_func;
2037 }
2038
2039 # make_custom_func
2040 # Create custom check function.
2041 sub make_custom_func {
2042     my $customcheck = shift;
2043     if (!defined $customcheck) {
2044         ld_log( _message('ERR0505') );
2045         return \&check_off;
2046     }
2047
2048     # closure
2049     my $custom_func = sub {
2050         my ($v, $r) = @_;
2051         my $status = get_status([[$v, $r]]);
2052         my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2053         my $ip_port  = $r->{server}{ip} . ':' . $port;
2054
2055         # expand macro
2056         $customcheck =~ s/_IP_/$r->{server}{ip}/g;
2057         $customcheck =~ s/_PORT_/$port/g;
2058
2059         my $res;
2060         {
2061             local $SIG{__DIE__} = 'DEFAULT';
2062             local $SIG{ALRM} = sub { die "custom check timeout\n"; };
2063             eval {
2064                 alarm $v->{checktimeout};
2065                 $res = system_wrapper($customcheck);
2066                 alarm 0;
2067             };
2068             alarm 0;
2069             if ($EVAL_ERROR) {
2070                 ld_log( _message('WRN3301', $v->{checktimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2071                 return $SERVICE_DOWN;
2072             }
2073         }
2074         if ($res) {
2075                 ld_log( _message('WRN3302', $customcheck, $res) ) if (!defined $status || $status eq $SERVICE_UP);
2076                 return $SERVICE_DOWN;
2077         }
2078         ld_log( _message('WRN0215', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2079         return $SERVICE_UP;
2080     };
2081
2082     return $custom_func;
2083 }
2084
2085 # check_http
2086 # HTTP service health check.
2087 # Send GET/HEAD request, and check response
2088 sub check_http {
2089     require LWP::UserAgent;
2090     require LWP::Debug;
2091     if ( $DEBUG_LEVEL > 2 ) {
2092         LWP::Debug::level('+');
2093     }
2094     my ( $v, $r ) = @_;
2095     my $status = get_status([[$v, $r]]);
2096
2097     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2098
2099     if ( $r->{url} !~ m{^https?://([^:/]+)} ) {
2100         ld_log( _message( 'WRN1101', $r->{url}, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2101         return $SERVICE_DOWN;
2102     }
2103     my $host = $1;
2104     my $virtualhost = defined $v->{virtualhost} ? $v->{virtualhost} : $host;
2105
2106     ld_debug(2, "check_http: url=\"$r->{url}\" " . "virtualhost=\"$virtualhost\"");
2107
2108     my $ua = LWP::UserAgent->new( timeout => $v->{negotiatetimeout} );
2109     my $req = new HTTP::Request( $v->{httpmethod}, $r->{url}, [ Host => $virtualhost ] );
2110     my $res;
2111     {
2112         # LWP makes ungaurded calls to eval
2113         # which throw a fatal exception if they fail
2114         local $SIG{__DIE__} = 'DEFAULT';
2115         local $SIG{ALRM} = sub { die "Can't connect to $r->{server}{ip}:$port (connect: timeout)\n"; };
2116         eval {
2117             alarm $v->{negotiatetimeout};
2118             $res = $ua->request($req);
2119             alarm 0;
2120         };
2121         alarm 0;
2122     }
2123
2124     my $status_line = $res->status_line;
2125     $status_line =~ s/[\r\n]//g;
2126
2127     my $response = "";
2128     my ($res_head, $res_body) = split /\n\n/, $res->as_string, 2;
2129     if ($v->{httpmethod} eq "HEAD") {
2130         $response = $res_head;
2131     }
2132     else {
2133         $response = $res_body;
2134     }
2135
2136     my $recstr = $r->{receive};
2137     if (!$res->is_success) {
2138         ld_log( _message( 'WRN1102', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2139         return $SERVICE_DOWN;
2140     }
2141     elsif (defined $recstr && $response !~ /$recstr/) {
2142         ld_log( _message( 'WRN1103', $recstr, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2143         ld_debug(3, "HTTP Response " . $res->headers->as_string);
2144         ld_debug(2, "check_http: $r->{url} is down\n");
2145         return $SERVICE_DOWN;
2146     }
2147
2148     ld_debug(2, "check_http: $r->{url} is up\n");
2149     ld_log( _message( 'WRN0203', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2150     return $SERVICE_UP;
2151 }
2152
2153 # check_smtp
2154 # SMTP service health check.
2155 # Connect SMTP server and check first response
2156 sub check_smtp {
2157     require Net::SMTP;
2158     my ($v, $r) = @_;
2159     my $status = get_status([[$v, $r]]);
2160
2161     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2162
2163     ld_debug(2, "Checking http: server=$r->{server}{ip} port=$port");
2164     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2165
2166     my $smtp = Net::SMTP->new(
2167         $r->{server}{ip},
2168         Port    => $port,
2169         Timeout => $v->{negotiatetimeout},
2170         Debug   => $debug_flag,
2171     );
2172     if (!$smtp) {
2173         ld_log( _message('WRN1201', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2174         return $SERVICE_DOWN;
2175     }
2176     $smtp->quit;
2177
2178     ld_log( _message('WRN0204', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2179     return $SERVICE_UP;
2180 }
2181
2182 # check_pop
2183 # POP3 service health check.
2184 # Connect POP3 server and login if user-pass specified.
2185 sub check_pop {
2186     require Net::POP3;
2187     my ($v, $r) = @_;
2188     my $status = get_status([[$v, $r]]);
2189
2190     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2191
2192     ld_debug(2, "Checking pop server=$r->{server}{ip} port=$port");
2193     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2194
2195     my $pop = Net::POP3->new(
2196         $r->{server}{ip},
2197         Port    => $port,
2198         Timeout => $v->{negotiatetimeout},
2199         Debug   => $debug_flag,
2200     );
2201     if (!$pop) {
2202         ld_log( _message('WRN1301', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2203         return $SERVICE_DOWN;
2204     }
2205
2206     if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
2207         $pop->user( $v->{login} );
2208         my $num = $pop->pass( $v->{passwd} );
2209         if (!defined $num) {
2210             ld_log( _message('WRN1302', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2211             $pop->quit();
2212             return $SERVICE_DOWN;
2213         }
2214     }
2215     $pop->quit();
2216
2217     ld_log( _message('WRN0205', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2218     return $SERVICE_UP;
2219 }
2220
2221 # check_imap
2222 # IMAP service health check.
2223 # Connect IMAP server and login if user-pass specified.
2224 sub check_imap {
2225     require Mail::IMAPClient;
2226     my ($v, $r) = @_;
2227     my $status = get_status([[$v, $r]]);
2228
2229     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2230
2231     ld_debug(2, "Checking imap server=$r->{server}{ip} port=$port");
2232     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2233
2234     my $imap;
2235     {
2236         local $SIG{ALRM} = sub { die "Connection timeout\n"; };
2237         eval {
2238             alarm $v->{negotiatetimeout};
2239             $imap = Mail::IMAPClient->new(
2240                 Server   => $r->{server}{ip},
2241                 Port     => $port,
2242                 Timeout  => $v->{negotiatetimeout},
2243                 Debug    => $debug_flag,
2244             );
2245             alarm 0;
2246         };
2247         alarm 0;
2248         if ($EVAL_ERROR) {
2249             ld_log( _message('WRN1403', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2250             return $SERVICE_DOWN;
2251         }
2252     }
2253     if (!$imap) {
2254         ld_log( _message('WRN1401', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2255         return $SERVICE_DOWN;
2256     }
2257
2258     if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
2259         $imap->User( $v->{login} );
2260         $imap->Password( $v->{passwd} );
2261         my $authres = $imap->login();
2262         if (!$authres) {
2263             ld_log( _message('WRN1402', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2264             $imap->logout();
2265             return $SERVICE_DOWN;
2266         }
2267     }
2268     $imap->logout();
2269
2270     ld_log( _message('WRN0206', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2271     return $SERVICE_UP;
2272 }
2273
2274 # check_ldap
2275 # LDAP service health check.
2276 # Connect LDAP server and search if base-DN specified by 'request'
2277 sub check_ldap {
2278     require Net::LDAP;
2279     my ($v, $r) = @_;
2280     my $status = get_status([[$v, $r]]);
2281
2282     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2283
2284     ld_debug(2, "Checking ldap server=$r->{server}{ip} port=$port");
2285     my $debug_flag = $DEBUG_LEVEL ? 15 : 0;
2286
2287     my $ldap = Net::LDAP->new(
2288         $r->{server}{ip},
2289         port    => $port,
2290         timeout => $v->{negotiatetimeout},
2291         debug   => $debug_flag,
2292     );
2293     if (!$ldap) {
2294         ld_log( _message('WRN1501', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2295         return $SERVICE_DOWN;
2296     }
2297
2298     my $mesg;
2299     {
2300         local $SIG{ALRM} = sub { die "Connection timeout\n"; };
2301         eval {
2302             alarm $v->{negotiatetimeout};
2303             $mesg = $ldap->bind;
2304             alarm 0;
2305         };
2306         alarm 0;
2307         if ($EVAL_ERROR) {
2308             ld_log( _message('WRN1502', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2309             return $SERVICE_DOWN;
2310         }
2311     }
2312     if ($mesg->is_error) {
2313         ld_log( _message('WRN1503', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2314         return $SERVICE_DOWN;
2315     }
2316
2317     if ( defined $r->{request} && $r->{request} ne q{} ) {
2318         ld_debug( 4, "Base : " . $r->{request} );
2319         my $result = $ldap->search(
2320             base   => $r->{request},
2321             scope  => 'base',
2322             filter => '(objectClass=*)',
2323         );
2324
2325         if ($result->count != 1) {
2326             ld_log( _message('WRN1504', $result->count, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2327             $ldap->unbind;
2328             return $SERVICE_DOWN;
2329         }
2330
2331         if ( defined $r->{receive} ) {
2332             my $href       = $result->as_struct;
2333             my @arrayOfDNs = keys %$href;
2334             my $recstr = $r->{receive};
2335             if ($recstr =~ /.+/ && $arrayOfDNs[0] !~ /$recstr/) {
2336                 ld_log( _message('WRN1505', $recstr, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2337                 $ldap->unbind;
2338                 return $SERVICE_DOWN;
2339             }
2340         }
2341     }
2342     $ldap->unbind;
2343
2344     ld_log( _message('WRN0207', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2345     return $SERVICE_UP;
2346 }
2347
2348 # check_nntp
2349 # NNTP service health check.
2350 # Connect NNTP server and check response start with '2**'
2351 sub check_nntp {
2352     require IO::Socket;
2353     require IO::Select;
2354     my ($v, $r) = @_;
2355     my $status = get_status([[$v, $r]]);
2356
2357     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2358
2359     ld_debug(2, "Checking nntp server=$r->{server}{ip} port=$port");
2360
2361     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
2362     if (!$sock) {
2363         ld_log( _message('WRN1601', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2364         return $SERVICE_DOWN;
2365     }
2366
2367     ld_debug(3, "Connected to $r->{server}{ip} (port $port)");
2368     my $select = IO::Select->new();
2369     $select->add($sock);
2370     if ( !defined $select->can_read( $v->{negotiatetimeout} ) ) {
2371         ld_log( _message('WRN1602', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2372         $select->remove($sock);
2373         $sock->close;
2374         return $SERVICE_DOWN;
2375     }
2376
2377     my $buf;
2378     sysread $sock, $buf, 64;
2379     $select->remove($sock);
2380     $sock->close;
2381     my ($response) = split /[\r\n]/, $buf;
2382
2383     if ($response !~ /^2/) {
2384         ld_log( _message('WRN1603', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2385         return $SERVICE_DOWN;
2386     }
2387
2388     ld_log( _message('WRN0208', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2389     return $SERVICE_UP;
2390 }
2391
2392 # check_mysql
2393 # MySQL service health check.
2394 # call check_sql and use MySQL driver
2395 sub check_mysql {
2396     return check_sql(@_, 'mysql', 'database');
2397 }
2398
2399 # check_pgsql
2400 # PostgreSQL service health check.
2401 # call check_sql and use PostgreSQL driver
2402 sub check_pgsql {
2403     return check_sql(@_, 'Pg', 'dbname');
2404 }
2405
2406 # check_sql
2407 # DBI service health check.
2408 # Login DB and send query if query specified by 'request', check result row number same as 'receive'
2409 sub check_sql {
2410     require DBI;
2411     my ($v, $r, $dbd, $dbname) = @_;
2412     my $status = get_status([[$v, $r]]);
2413
2414     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2415
2416     if ( !defined $v->{login} || !defined $v->{passwd} || !defined $v->{database} ||
2417            $v->{login} eq q{} || $v->{database} eq q{} ) {
2418         ld_log( _message('WRN1701', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2419         return $SERVICE_DOWN;
2420     }
2421
2422     ld_debug(2, "Checking $v->{server}{ip} server=$r->{server}{ip} port=$port\n");
2423
2424     my $mask = POSIX::SigSet->new(SIGALRM);
2425     my $action = POSIX::SigAction->new(
2426         sub { die "Connection timeout\n" },
2427         $mask,
2428     );
2429     my $oldaction = POSIX::SigAction->new();
2430     sigaction(SIGALRM, $action, $oldaction);
2431
2432     my $dbh;
2433     eval {
2434         alarm $v->{negotiatetimeout};
2435
2436         DBI->trace(15) if $DEBUG_LEVEL;
2437         $dbh = DBI->connect( "dbi:$dbd:$dbname=$v->{database};host=$r->{server}{ip};port=$port", $v->{login}, $v->{passwd} );
2438         DBI->trace(0);
2439
2440         if (!defined $dbh) {
2441             alarm 0;
2442             sigaction(SIGALRM, $oldaction);
2443             ld_log( _message('WRN1702', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2444             die;
2445         }
2446
2447         local $dbh->{TraceLevel} = $DEBUG_LEVEL ? 15 : 0;
2448
2449         my $rows = 0;
2450
2451         if ( defined $r->{request} && $r->{request} ne q{} ) {
2452             my $sth  = $dbh->prepare( $r->{request} );
2453             $rows = $sth->execute;
2454             $sth->finish;
2455         }
2456
2457         $dbh->disconnect;
2458
2459         alarm 0;
2460         sigaction(SIGALRM, $oldaction);
2461
2462         if ( defined $r->{request} && $r->{request} ne q{} ) {
2463             ld_debug(4, "Database search returned $rows rows");
2464             if ($rows == 0) {
2465                 ld_log( _message('WRN1703', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2466                 die;
2467             }
2468             # If user defined a receive string (number of rows returned), only do
2469             # the check if the previous fetchall_arrayref succeeded.
2470             if (defined $r->{receive} && $r->{receive} =~ /^\d+$/) {
2471                 # Receive string specifies an exact number of rows
2472                 if ( $rows ne $r->{receive} ) {
2473                     ld_log( _message('WRN1704', $r->{receive}, $rows, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2474                     die;
2475                 }
2476             }
2477         }
2478     };
2479     alarm 0;
2480     sigaction(SIGALRM, $oldaction);
2481     if ($EVAL_ERROR) {
2482         if ($EVAL_ERROR eq "Connection timeout\n") {
2483             ld_log( _message('WRN1705', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2484         }
2485         return $SERVICE_DOWN;
2486     }
2487
2488     ld_log( _message('WRN0209', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2489     return $SERVICE_UP;
2490 }
2491
2492 # check_connect
2493 # Connect service health check.
2494 # Just connect port and close.
2495 sub check_connect {
2496     my ($v, $r) = @_;
2497     my $status = get_status([[$v, $r]]);
2498
2499     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2500
2501     ld_debug(2, "Checking connect: real server=$r->{server}{ip}:$port");
2502
2503     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{checktimeout} );
2504     if (!defined $sock) {
2505         ld_log( _message('WRN3201', $ERRNO, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2506         return $SERVICE_DOWN;
2507     }
2508     close($sock);
2509
2510     ld_debug(3, "Connected to: (port $port)");
2511
2512     ld_log( _message('WRN0210', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2513     return $SERVICE_UP;
2514 }
2515
2516 # check_sip
2517 # SIP service health check.
2518 # Send SIP OPTIONS request and check 200 response
2519 sub check_sip {
2520     my ($v, $r) = @_;
2521     my $status = get_status([[$v, $r]]);
2522
2523     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2524
2525     ld_debug(2, "Checking sip server=$r->{server}{ip} port=$port");
2526
2527     if ( !defined $v->{login} ) {
2528         ld_log( _message('WRN1801', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2529         return $SERVICE_DOWN;
2530     }
2531
2532     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
2533     if (!defined $sock) {
2534         ld_log( _message('WRN1802', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2535         return $SERVICE_DOWN;
2536     }
2537
2538     my $sip_s_addr = $sock->sockhost;
2539     my $sip_s_port = $sock->sockport;
2540
2541     ld_debug(3, "Connected from $sip_s_addr:$sip_s_port to " . $r->{server} . ":$port");
2542
2543     my $id = $v->{login};
2544     my $request =
2545           "OPTIONS sip:$id SIP/2.0\r\n"
2546         . "Via: SIP/2.0/UDP $sip_s_addr:$sip_s_port;branch=z9hG4bKhjhs8ass877\r\n"
2547         . "Max-Forwards: 70\r\n"
2548         . "To: <sip:$id>\r\n"
2549         . "From: <sip:$id>;tag=1928301774\r\n"
2550         . "Call-ID: a84b4c76e66710\r\n"
2551         . "CSeq: 63104 OPTIONS\r\n"
2552         . "Contact: <sip:$id>\r\n"
2553         . "Accept: application/sdp\r\n"
2554         . "Content-Length: 0\r\n"
2555         . "\r\n";
2556
2557     ld_debug(3, "Request:\n$request");
2558
2559     my $response;
2560     eval {
2561         local $SIG{__DIE__} = 'DEFAULT';
2562         local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
2563         ld_debug(4, "Timeout is $v->{negotiatetimeout}");
2564         alarm $v->{negotiatetimeout};
2565
2566         print {$sock} $request;
2567         $response = <$sock>;
2568         close $sock;
2569         alarm 0;
2570
2571         ld_debug(3, "Response:\n$response");
2572
2573         if ( $response !~ m{^SIP/2\.0 200 OK} ) {
2574             ld_log( _message('WRN1803', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2575             die;
2576         }
2577     };
2578     alarm 0;
2579     if ($EVAL_ERROR) {
2580         if ($EVAL_ERROR eq "Connection timeout\n") {
2581             ld_log( _message('WRN1804', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2582         }
2583         return $SERVICE_DOWN;
2584     }
2585
2586     ld_log( _message('WRN0211', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2587     return $SERVICE_UP;
2588 }
2589
2590 # check_ftp
2591 # FTP service health check.
2592 # Login server and get file if 'request' specified, and check file include 'receive' string
2593 sub check_ftp {
2594     require Net::FTP;
2595     my ($v, $r) = @_;
2596     my $status = get_status([[$v, $r]]);
2597
2598     my $ip_port = get_ip_port($r, $v->{checkport});
2599
2600     ld_debug(2, "Checking ftp server=$ip_port");
2601     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2602
2603     if ( !defined $v->{login} || !defined $v->{passwd} || $v->{login} eq q{} ) {
2604         ld_log( _message('WRN1901', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2605         return $SERVICE_DOWN;
2606     }
2607
2608     my $ftp = Net::FTP->new(
2609             $ip_port,
2610             Timeout => $v->{negotiatetimeout},
2611             Passive => 1,
2612             Debug   => $debug_flag,
2613          );
2614     if (!defined $ftp) {
2615         ld_log( _message('WRN1902', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2616         return $SERVICE_DOWN;
2617     }
2618     if ( !$ftp->login( $v->{login}, $v->{passwd} ) ) {
2619         ld_log( _message('WRN1903', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2620         $ftp->quit();
2621         return $SERVICE_DOWN;
2622     }
2623     if ( !$ftp->cwd('/') ) {
2624         ld_log( _message('WRN1904', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2625         $ftp->quit();
2626         return $SERVICE_DOWN;
2627     }
2628     if ( $r->{request} ) {
2629         my $fail_flag = 0;
2630         eval {
2631             local $SIG{__DIE__} = 'DEFAULT';
2632             local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
2633             alarm $v->{negotiatetimeout};
2634
2635             open my $tmp, '+>', undef;
2636             $ftp->binary();
2637             if ( !$ftp->get( $r->{request}, *$tmp ) ) {
2638                 alarm 0;
2639                 ld_log( _message('WRN1905', $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2640                 close $tmp;
2641                 $ftp->quit();
2642                 $fail_flag = 1;
2643             }
2644             elsif ( $r->{receive} ) {
2645                 seek $tmp, 0, 0;
2646                 local $/;
2647                 my $memory = <$tmp>;
2648                 close $tmp;
2649                 if ($memory !~ /$r->{receive}/) {
2650                     alarm 0;
2651                     $ftp->quit();
2652                     ld_log( _message('WRN1906', $r->{receive}, $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2653                     $fail_flag = 1;
2654                 }
2655             }
2656         };
2657         alarm 0;
2658         if ($EVAL_ERROR) {
2659             $ftp->quit();
2660             my $error_message = $EVAL_ERROR;
2661             $error_message =~ s/[\r\n]//g;
2662             if ($error_message eq 'Connection timeout') {
2663                 ld_log( _message('WRN1908', $v->{negotiatetimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2664             }
2665             else {
2666                 ld_log( _message('WRN1907', $error_message, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2667             }
2668             return $SERVICE_DOWN;
2669         }
2670         if ($fail_flag) {
2671             $ftp->quit();
2672             return $SERVICE_DOWN;
2673         }
2674     }
2675     $ftp->quit();
2676
2677     ld_log( _message('WRN0212', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2678     return $SERVICE_UP;
2679 }
2680
2681 # check_dns
2682 # DNS service health check.
2683 # Connect server and search 'request' A or PTR record and check result include 'response' string
2684 sub check_dns {
2685     my ($v, $r) = @_;
2686     my $status = get_status([[$v, $r]]);
2687
2688     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2689
2690     {
2691         # Net::DNS makes ungaurded calls to eval
2692         # which throw a fatal exception if they fail
2693         local $SIG{__DIE__} = 'DEFAULT';
2694         require Net::DNS;
2695     }
2696     my $res = Net::DNS::Resolver->new();
2697
2698     if ($DEBUG_LEVEL) {
2699         $res->debug(1);
2700     }
2701
2702     if ( !defined $r->{request} || $r->{request} eq q{} || !defined $r->{receive} || $r->{receive} eq q{} ) {
2703         ld_log( _message('WRN2001', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2704         return $SERVICE_DOWN;
2705     }
2706     ld_debug( 2, qq(Checking dns: request="$r->{request}" receive="$r->{receive}"\n) );
2707
2708     my $packet;
2709     eval {
2710         local $SIG{__DIE__} = 'DEFAULT';
2711         local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
2712         alarm $v->{negotiatetimeout};
2713         $res->nameservers( $r->{server}{ip} );
2714         $res->port($port);
2715         $packet = $res->search( $r->{request} );
2716         alarm 0;
2717     };
2718     alarm 0;
2719     if ($EVAL_ERROR) {
2720         if ($EVAL_ERROR eq "Connection timeout\n") {
2721             ld_log( _message('WRN2002', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2722         }
2723         else {
2724             ld_log( _message('WRN2003', $EVAL_ERROR, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2725         }
2726         return $SERVICE_DOWN;
2727     }
2728     if (!$packet) {
2729         ld_log( _message('WRN2004', $r->{request}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2730         return $SERVICE_DOWN;
2731     }
2732
2733     my $match = 0;
2734     for my $rr ($packet->answer) {
2735         if (   ( $rr->type eq 'A'   && $rr->address  eq $r->{receive} )
2736             || ( $rr->type eq 'PTR' && $rr->ptrdname eq $r->{receive} ) ) {
2737             $match = 1;
2738             last;
2739         }
2740     }
2741     if (!$match) {
2742         ld_log( _message('WRN2005', $r->{receive}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2743         return $SERVICE_DOWN;
2744     }
2745
2746     ld_log( _message('WRN0213', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2747     return $SERVICE_UP;
2748 }
2749
2750 # check_ping
2751 # ICMP ping service health check.
2752 # Ping server and check response.
2753 sub check_ping {
2754     require Net::Ping;
2755     my ($v, $r) = @_;
2756     my $status = get_status([[$v, $r]]);
2757
2758     ld_debug( 2, qq(Checking ping: host="$r->{server}{ip}" checktimeout="$v->{checktimeout}"\n) );
2759
2760     my $p = Net::Ping->new('icmp', 1, 64);
2761     if ( !$p->ping( $r->{server}{ip}, $v->{checktimeout} ) ) {
2762         ld_log( _message('WRN3101', $v->{checktimeout}, $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_UP);
2763         return $SERVICE_DOWN;
2764     }
2765
2766     ld_log( _message('WRN0214', $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2767     return $SERVICE_UP;
2768 }
2769
2770 # check_none
2771 # Dummy function to check service if service type is none.
2772 # Just activates the real server
2773 sub check_none {
2774     my ($v, $r) = @_;
2775     ld_debug(2, "Checking none");
2776     return $SERVICE_UP;
2777 }
2778
2779 # check_off
2780 # Check nothing and always return $SERVICE_DOWN
2781 sub check_off {
2782     my ($v, $r) = @_;
2783     return $SERVICE_DOWN;
2784 }
2785
2786 # check_on
2787 # Check nothing and always return $SERVICE_UP
2788 sub check_on {
2789     my ($v, $r) = @_;
2790     return $SERVICE_UP;
2791 }
2792
2793 # service_set
2794 # Used to bring up and down real servers.
2795 # This is the function you should call if you want to bring a real
2796 # server up or down.
2797 # This function is safe to call regrdless of the current state of a
2798 # real server.
2799 # Do _not_ call _service_up or _service_down directly.
2800 # pre: v_r_list: virtual and real pair list
2801 #                [ [$v, $r], [$v, $r] ... ]
2802 #      state: up or down
2803 #             up to bring the real service up
2804 #             down to bring the real service up
2805 # post: The real server is brough up or down for each virtual service
2806 #       it belongs to.
2807 # return: none
2808 sub service_set {
2809     my ($v_r_list, $state) = @_;
2810
2811     if (defined $state && $state eq 'up') {
2812         _service_up($v_r_list);
2813     }
2814     elsif (defined $state && $state eq 'down') {
2815         _service_down($v_r_list);
2816     }
2817 }
2818
2819 # _service_up
2820 # Bring a real service up if it is down
2821 # Should be called by service_set only
2822 # I.e. If you want to change the state of a real server call service_set.
2823 #      If you call this function directly then l7directord will lose track
2824 #      of the state of real servers.
2825 # pre: v_r_list: virtual and real pair list
2826 #                [ [$v, $r], [$v, $r] ... ]
2827 # post: real service is taken up from the respective virtual service
2828 #       if it is inactive
2829 # return: none
2830 sub _service_up {
2831     my $v_r_list = shift;
2832     if ( !_status_up($v_r_list) ) {
2833         return;
2834     }
2835
2836     for my $v_r_pair (@$v_r_list) {
2837         my ($v, $r) = @$v_r_pair;
2838         _restore_service($v, $r, 'real');
2839         fallback_off($v);
2840     }
2841 }
2842
2843 # _service_down
2844 # Bring a real service down if it is up
2845 # Should be called by service_set only
2846 # I.e. if you want to change the state of a real server call service_set.
2847 #      If you call this function directly then l7directord will lose track
2848 #      of the state of real servers.
2849 # pre: v_r_list: virtual and real pair list
2850 #                [ [$v, $r], [$v, $r] ... ]
2851 # post: real service is taken down from the respective virtual service
2852 #       if it is active
2853 # return: none
2854 sub _service_down {
2855     my $v_r_list = shift;
2856     if ( !_status_down($v_r_list) ) {
2857         return;
2858     }
2859
2860     for my $v_r_pair (@$v_r_list) {
2861         my ($v, $r) = @$v_r_pair;
2862         _remove_service($v, $r, 'real');
2863         fallback_on($v);
2864     }
2865 }
2866
2867 # _status_up
2868 # Set the status of a server as up
2869 # Should only be called from _service_up or fallback_on
2870 sub _status_up {
2871     my ($v_r_list, $is_fallback) = @_;
2872     if (!defined $v_r_list) {
2873         return 0;
2874     }
2875
2876     if (!$is_fallback) {
2877         my $current_status = get_status($v_r_list);
2878         if (defined $current_status && $current_status eq $SERVICE_UP) {
2879             return 0;
2880         }
2881
2882         my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
2883         if (!defined $id) {
2884             ld_log( _message('ERR0503') );
2885             return 0;
2886         }
2887         $HEALTH_CHECK{$id}{status} = $SERVICE_UP;
2888
2889         return 1;
2890     }
2891     else {
2892         my $current_service = ld_read_l7vsadm();
2893         if (!defined $current_service) {
2894             ld_log( _message('FTL0201') );
2895             return 0;
2896         }
2897         my $vid = get_virtual_id_str( $v_r_list->[0][0] );
2898         if ( exists $current_service->{$vid} ) {
2899             # no real server
2900             if ( !defined $current_service->{$vid} ) {
2901                 return 1;
2902             }
2903             my $weight = 0;
2904             # all real server's weight are zero.
2905             for my $real ( keys %{ $current_service->{$vid} } ) {
2906                 # already added fallback server.
2907                 if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
2908                     return 0;
2909                 }
2910                 $weight += $current_service->{$vid}{$real}{weight};
2911             }
2912             if ($weight == 0) {
2913                 return 1;
2914             }
2915         }
2916         return 0;
2917     }
2918 }
2919
2920 # _status_down
2921 # Set the status of a server as down
2922 # Should only be called from _service_down or _ld_stop
2923 sub _status_down {
2924     my ($v_r_list, $is_fallback) = (@_);
2925     if (!defined $v_r_list) {
2926         return 0;
2927     }
2928
2929     if (!$is_fallback) {
2930         my $current_status = get_status($v_r_list);
2931         if ($current_status && $current_status eq $SERVICE_DOWN) {
2932             return 0;
2933         }
2934
2935         my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
2936         if (!defined $id) {
2937             ld_log( _message('ERR0503') );
2938             return 0;
2939         }
2940         $HEALTH_CHECK{$id}{status} = $SERVICE_DOWN;
2941
2942         return 1;
2943     }
2944     else {
2945         my $current_service = ld_read_l7vsadm();
2946         if (!defined $current_service) {
2947             ld_log( _message('FTL0201') );
2948             return 0;
2949         }
2950         my $vid = get_virtual_id_str( $v_r_list->[0][0] );
2951         if ( defined $current_service->{$vid} ) {
2952             my $weight = 0;
2953             my $fallback_exist = 0;
2954             # any real server has weight.
2955             for my $real ( keys %{ $current_service->{$vid} } ) {
2956                 if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
2957                     $fallback_exist = 1;
2958                 }
2959                 $weight += $current_service->{$vid}{$real}{weight};
2960             }
2961             if ($fallback_exist && $weight) {
2962                 return 1;
2963             }
2964         }
2965         return 0;
2966     }
2967 }
2968
2969 # get_status
2970 # Get health check server status
2971 # return $SERVICE_UP / $SERVICE_DOWN
2972 sub get_status {
2973     my $v_r_list = shift;
2974
2975     my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
2976     if (!defined $id) {
2977         ld_log( _message('ERR0503') );
2978         return 0;
2979     }
2980     return $HEALTH_CHECK{$id}{status};
2981 }
2982
2983 # _remove_service
2984 # Remove a real server by either making it quiescent or deleteing it
2985 # Should be called by _service_down or fallback_off
2986 # I.e. If you want to change the state of a real server call service_set.
2987 #      If you call this function directly then l7directord will lose track
2988 #      of the state of real servers.
2989 # If the real server exists (which it should) make it quiescent or
2990 # delete it, depending on the global and per virtual service quiecent flag.
2991 # If it # doesn't exist, just leave it as it will be added by the
2992 # _service_up code as appropriate.
2993 # pre: v: reference to virtual service to with the real server belongs
2994 #      rservice: service to restore. Of the form server:port for tcp
2995 #      rforw: Forwarding mechanism of service. Should be only "-m"
2996 #    rforw is kept as it is, even though not used - NTT COMWARE
2997 #      tag: Tag to use for logging. Should be either "real" or "fallback"
2998 # post: real service is taken up from the respective virtual service
2999 #       if it is inactive
3000 # return: none
3001 sub _remove_service {
3002     my ($v, $r, $tag) = @_;
3003     if (!defined $v || !defined $r) {
3004         ld_log( _message('ERR0501') );
3005         return;
3006     }
3007
3008     my $vip_id = get_virtual_id_str($v);
3009     if (!defined $vip_id) {
3010         ld_log( _message('ERR0502') );
3011         return;
3012     }
3013     my $oldsrv = ld_read_l7vsadm();
3014     if (!defined $oldsrv) {
3015         ld_log( _message('FTL0201') );
3016         return;
3017     }
3018
3019     if ( !exists $oldsrv->{$vip_id} ) {
3020         ld_log( _message( 'ERR0208', get_ip_port($r), get_ip_port($v) ) );
3021         return;
3022     }
3023
3024     # quiescent check
3025     my $is_quiescent = 0;
3026     if (!defined $tag || $tag ne 'fallback') {
3027         if ( defined $v->{quiescent} && $v->{quiescent} ) {
3028             $is_quiescent = 1;
3029         }
3030     }
3031
3032     my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
3033     # already removed server
3034     if (!defined $or && !$is_quiescent) {
3035         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3036         ld_log( _message( 'ERR0210', get_ip_port($r), get_ip_port($v), $module_key ) );
3037         return;
3038     }
3039     # already quiescent server
3040     if ( defined $or && $is_quiescent && $or->{weight} == 0 &&
3041          $or->{option}{forward} eq $r->{option}{forward} ) {
3042         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3043         ld_log( _message( 'ERR0211', get_ip_port($r), get_ip_port($v), $module_key ) );
3044         return;
3045     }
3046
3047     if ($is_quiescent) {
3048         if (defined $or) {
3049             ld_edit_real($v, $r, 0);
3050         }
3051         else {
3052             ld_add_real($v, $r, 0);
3053         }
3054         if (!defined $tag || $tag eq 'real') {
3055             ld_log( _message( 'INF0303', get_ip_port($r) ) );
3056         }
3057         elsif ($tag eq 'fallback') {
3058             ld_log( _message( 'INF0304', get_ip_port($r) ) );
3059         }
3060     }
3061     else {
3062         ld_delete_real($v, $r);
3063         if (!defined $tag || $tag eq 'real') {
3064             ld_log( _message( 'INF0305', get_ip_port($r) ) );
3065         }
3066         elsif ($tag eq 'fallback') {
3067             ld_log( _message( 'INF0306', get_ip_port($r) ) );
3068         }
3069     }
3070
3071     if ( defined $v->{realdowncallback} && $r->{healthchecked} ) {
3072         system_wrapper( $v->{realdowncallback}, get_ip_port($r) );
3073         ld_log( _message( 'INF0501',  $v->{realdowncallback}, get_ip_port($r) ) );
3074     }
3075     $r->{healthchecked} = 1;
3076 }
3077
3078 # _restore_service
3079 # Make a retore a real server. The opposite of _quiescent_server.
3080 # Should be called by _service_up or fallback_on
3081 # I.e. If you want to change the state of a real server call service_set.
3082 #      If you call this function directly then l7directord will lose track
3083 #      of the state of real servers.
3084 # If the real server exists (which it should) make it quiescent. If it
3085 # doesn't exist, just leave it as it will be added by the _service_up code
3086 # as appropriate.
3087 # pre: v: reference to virtual service to with the real server belongs
3088 #      r: reference to real server to restore.
3089 #      tag: Tag to use for logging. Should be either "real" or "fallback"
3090 # post: real service is taken up from the respective virtual service
3091 #       if it is inactive
3092 # return: none
3093 sub _restore_service {
3094     my ($v, $r, $tag) = @_;
3095     if (!defined $v || !defined $r) {
3096         ld_log( _message('ERR0501') );
3097         return;
3098     }
3099
3100     my $vip_id = get_virtual_id_str($v);
3101     if (!defined $vip_id) {
3102         ld_log( _message('ERR0502') );
3103         return;
3104     }
3105     my $oldsrv = ld_read_l7vsadm();
3106     if (!defined $oldsrv) {
3107         ld_log( _message('FTL0201') );
3108         return;
3109     }
3110
3111     if ( !exists $oldsrv->{$vip_id} ) {
3112         ld_log( _message( 'ERR0207', get_ip_port($r), get_ip_port($v) ) );
3113         return;
3114     }
3115
3116     my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
3117     # already completely same server exist
3118     if ( defined $or &&
3119          $or->{weight} eq $r->{weight} &&
3120          $or->{option}{forward} eq $r->{option}{forward} ) {
3121         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3122         ld_log( _message( 'ERR0209', get_ip_port($r), get_ip_port($v), $module_key ) );
3123         return;
3124     }
3125
3126     if (defined $or) {
3127         ld_edit_real( $v, $r, $r->{weight} );
3128     }
3129     else {
3130         ld_add_real( $v, $r, $r->{weight} );
3131     }
3132
3133     if (!defined $tag || $tag eq 'real') {
3134         ld_log( _message( 'INF0301', get_ip_port($r) ) );
3135     }
3136     elsif ($tag eq 'fallback') {
3137         ld_log( _message( 'INF0302', get_ip_port($r) ) );
3138     }
3139
3140     if ( defined $v->{realrecovercallback} && $r->{healthchecked} ){
3141         system_wrapper( $v->{realrecovercallback}, get_ip_port($r) );
3142         ld_log( _message( 'INF0502',  $v->{realrecovercallback}, get_ip_port($r) ) );
3143     }
3144     $r->{healthchecked} = 1;
3145 }
3146
3147 # fallback_on
3148 # Turn on the fallback server for a virtual service if it is inactive
3149 # pre: v: virtual to turn fallback service on for
3150 # post: fallback server is turned on if it was inactive
3151 # return: none
3152 sub fallback_on {
3153     my $v = shift;
3154
3155     my $fallback = fallback_find($v);
3156     if (defined $fallback) {
3157         my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
3158         if ( _status_up($v_r_list, 'fallback') ) {
3159             _restore_service($v, $fallback->{tcp}, 'fallback');
3160         }
3161     }
3162 }
3163
3164 # fallback_off
3165 # Turn off the fallback server for a virtual service if it is active
3166 # pre: v: virtual to turn fallback service off for
3167 # post: fallback server is turned off if it was active
3168 # return: none
3169 sub fallback_off {
3170     my $v = shift;
3171
3172     my $fallback = fallback_find($v);
3173     if (defined $fallback) {
3174         my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
3175         if ( _status_down($v_r_list, 'fallback') ) {
3176             _remove_service($v, $fallback->{tcp}, 'fallback');
3177         }
3178     }
3179 }
3180
3181 # fallback_find
3182 # Determine the fallback for a virtual service
3183 # pre: v: reference to a virtual service
3184 # post: none
3185 # return: $v->{fallback} if defined
3186 #         else undef
3187 sub fallback_find {
3188     my $v = shift;
3189     if (!defined $v) {
3190         ld_log( _message('ERR0501') );
3191         return;
3192     }
3193     return $v->{fallback};
3194 }
3195
3196 # check_cfgfile
3197 # Check configfile change.
3198 # pre: none
3199 # post: check configfile size, and then check md5 sum
3200 # return: 1 if notice file change
3201 #         0 if not notice or not change
3202 sub check_cfgfile {
3203     if (!defined $CONFIG_FILE{path}) {
3204         ld_log( _message('FTL0102') );
3205         return 0;
3206     }
3207
3208     my $mtime = (stat $CONFIG_FILE{path})[9];
3209     if (!defined $mtime) {
3210         ld_log( _message( 'ERR0410', $CONFIG_FILE{path} ) );
3211         return 0;
3212     }
3213
3214     if ( defined $CONFIG_FILE{stattime} && $mtime == $CONFIG_FILE{stattime} ) {
3215         # file mtime is not change
3216         return 0;
3217     }
3218     $CONFIG_FILE{stattime} = $mtime;
3219
3220     my $digest = undef;;
3221     eval {
3222         require Digest::MD5;
3223
3224         my $ctx = Digest::MD5->new();
3225         open my $config, '<', $CONFIG_FILE{path};
3226         $ctx->addfile($config);
3227         $digest = $ctx->hexdigest;
3228         close $config;
3229     };
3230     if ($EVAL_ERROR) {
3231         ld_log( _message( 'ERR0407', $CONFIG_FILE{path} ) );
3232         return 0;
3233     }
3234
3235     if (defined $CONFIG_FILE{checksum} && $digest &&
3236                 $CONFIG_FILE{checksum} ne $digest ) {
3237         ld_log( _message('WRN0101', $CONFIG_FILE{path}) );
3238         $CONFIG_FILE{checksum} = $digest;
3239
3240         if ( defined $CONFIG{callback} && -x $CONFIG{callback} ) {
3241             system_wrapper( $CONFIG{callback} . q{ } . $CONFIG_FILE{path} );
3242             ld_log( _message( 'INF0503',  $CONFIG{callback}, $CONFIG_FILE{path} ) );
3243         }
3244
3245         if ( $CONFIG{autoreload} ) {
3246             ld_log( _message('WRN0102') );
3247             return 1;
3248         }
3249         else {
3250             ld_log( _message('WRN0103') );
3251             return 0;
3252         }
3253     }
3254
3255     $CONFIG_FILE{checksum} = $digest;
3256     return 0;
3257 }
3258
3259 # ld_openlog
3260 # Open logger
3261 # make log rotation work
3262 # pre: log setting
3263 # post: If logger is a file, it opened and closed again as a test
3264 #       If logger is syslog, it is opened so it can be used without
3265 #       needing to be opened again.
3266 #       Otherwiese, nothing is done.
3267 # return: 0 on success
3268 #         1 on error
3269 sub ld_openlog {
3270     my $log_config = shift;
3271     if (!defined $log_config) {
3272         ld_log( _message('ERR0501') );
3273         return 1;
3274     }
3275
3276     if ( $DEBUG_LEVEL > 0 or $CONFIG{supervised} ) {
3277         # Instantly do nothing
3278         return 0;
3279     }
3280
3281     if ( $log_config =~ m{^/}) {
3282         # Open and close the file as a test.
3283         # We open the file each time we want to log to it
3284         eval {
3285             open my $log_file, ">>", $log_config;
3286             close $log_file;
3287         };
3288         if ($EVAL_ERROR) {
3289             ld_log( _message('ERR0118', $log_config) );
3290             return 1;
3291         }
3292     }
3293     else {
3294         # Assume $log_config is a logfacility, log to syslog
3295         setlogsock("unix");
3296         openlog("l7directord", "pid", $log_config);
3297         # FIXME "closelog" not found
3298     }
3299
3300     $PROC_STAT{log_opened} = 1;
3301     return 0;
3302 }
3303
3304 # ld_log
3305 # Log a message.
3306 # pre: message: Message to write
3307 # post: message and timetsamp is written to loged
3308 #       If logger is a file, it is opened and closed again as a
3309 #       primative means to make log rotation work
3310 # return: 0 on success
3311 #         1 on error
3312 sub ld_log {
3313     my $message = shift;
3314     if (!defined $message) {
3315         ld_log( _message('ERR0501') );
3316         return 1;
3317     }
3318
3319     ld_debug(2, $message);
3320     chomp $message;
3321
3322     if ( !$PROC_STAT{log_opened} ) {
3323         return 1;
3324     }
3325
3326     my $now = localtime();
3327     my $line_header = sprintf "[%s|%d] ", $now, $PROC_STAT{pid};
3328     $message =~ s/^/$line_header/mg;
3329
3330     if ( $CONFIG{supervised} ) {
3331         print {*STDOUT} $message . "\n";
3332     }
3333     elsif ( $CONFIG{logfile} =~ m{^/} ) {
3334         eval {
3335             open my $log_file, '>>', $CONFIG{logfile};
3336             flock $log_file, 2; # LOCK_EX
3337             print {$log_file} $message . "\n";
3338             close $log_file;
3339         };
3340         if ($EVAL_ERROR) {
3341             print {*STDERR} _message_only( 'FTL0103', $CONFIG{logfile}, $message ) . "\n";
3342             return 1;
3343         }
3344     }
3345     else {
3346         # Assume LOGFILE is a logfacility, log to syslog
3347         syslog('info', $message);
3348     }
3349     return 0;
3350 }
3351
3352 # ld_debug
3353 # Log a message to a STDOUT.
3354 # pre: priority: priority of message
3355 #      message: Message to write
3356 # post: message is written to STDOUT if $DEBUG_LEVEL >= priority
3357 # return: none
3358 sub ld_debug {
3359     my ($priority, $message) = @_;
3360
3361     if (defined $priority && $priority =~ /^\d+$/ &&
3362         defined $message  && $DEBUG_LEVEL >= $priority) {
3363         chomp $message;
3364         $message =~ s/^/DEBUG[$priority]: /mg;
3365         print {*STDERR} $message . "\n";
3366     }
3367 }
3368
3369 # command_wrapper
3370 # Wrapper around command(qx) to get output
3371 # pre: command to execute
3372 # post: execute command and if it returns non-zero a failure
3373 #       message is logged
3374 # return: return value of command, and output
3375 sub command_wrapper {
3376     my $command = shift;
3377
3378     if ($DEBUG_LEVEL > 2) {
3379         ld_log( _message( 'INF0506', $command) );
3380     }
3381
3382     $command =~ s/([{}\\])/\\$1/g;
3383     my $output = qx($command);
3384     if ($CHILD_ERROR != 0) {
3385         ld_log( _message('ERR0303', $command, $CHILD_ERROR) );
3386     }
3387     return ($CHILD_ERROR, $output);
3388 }
3389
3390 # system_wrapper
3391 # Wrapper around system() to log errors
3392 # pre: LIST: arguments to pass to system()
3393 # post: system() is called and if it returns non-zero a failure
3394 #       message is logged
3395 # return: return value of system()
3396 sub system_wrapper {
3397     my @args = @_;
3398
3399     if ($DEBUG_LEVEL > 2) {
3400         ld_log( _message( 'INF0504', join(q{ }, @args) ) );
3401     }
3402     my $status = system(@args);
3403     if ($DEBUG_LEVEL > 2) {
3404         if ($status != 0) {
3405             ld_log( _message('ERR0301', join(q{ }, @args), $status) );
3406         }
3407     }
3408     return $status;
3409 }
3410
3411 # exec_wrapper
3412 # Wrapper around exec() to log errors
3413 # pre: LIST: arguments to pass to exec()
3414 # post: exec() is called and if it returns non-zero a failure
3415 #       message is logged
3416 # return: return value of exec() on failure
3417 #         does not return on success
3418 sub exec_wrapper {
3419     my @args = @_;
3420
3421     if ($DEBUG_LEVEL > 2) {
3422         ld_log( _message( 'INF0505', join(q{ }, @args) ) );
3423     }
3424     my $status = exec(@args);
3425     if (!$status) {
3426         ld_log( _message('ERR0302', join(q{ }, @args), $status) );
3427     }
3428     return $status;
3429 }
3430
3431 # ld_rm_file
3432 # Remove a file, symink, or anything that isn't a directory
3433 # and exists
3434 # pre: filename: file to delete
3435 # post: If filename does not exist or is a directory an
3436 #       error state is reached
3437 #       Else filename is delete
3438 #       If $DEBUG_LEVEL >=2 errors are logged
3439 # return:  0 on success
3440 #         -1 on error
3441 sub ld_rm_file {
3442     my $filename = shift;
3443     if (!defined $filename) {
3444         ld_log( _message('ERR0411') );
3445         return -1;
3446     }
3447     if (-d $filename) {
3448         ld_log( _message('ERR0401', $filename) );
3449         return -1;
3450     }
3451     if (!-e $filename) {
3452         ld_log( _message('ERR0402', $filename) );
3453         return -1;
3454     }
3455     my $status = unlink $filename;
3456     if ($status != 1) {
3457         ld_log( _message('ERR0403', $filename, $ERRNO) );
3458         return -1;
3459     }
3460     return 0;
3461 }
3462
3463 # is_octet
3464 # See if a number is an octet, that is >=0 and <=255
3465 # pre: alleged_octet: the octect to test
3466 # post: alleged_octect is checked to see if it is valid
3467 # return: 1 if the alleged_octet is an octet
3468 #         0 otherwise
3469 sub is_octet {
3470     my $alleged_octet = shift;
3471     if (!defined $alleged_octet || $alleged_octet !~ /^\d+$/ || $alleged_octet > 255) {
3472         ld_log( _message('ERR0501') );
3473         return 0;
3474     }
3475     return 1;
3476 }
3477
3478 # is_ip
3479 # Check that a given string is an IP address
3480 # pre: alleged_ip: string representing ip address
3481 # post: alleged_ip is checked to see if it is valid
3482 # return: 1 if alleged_ip is a valid ip address
3483 #         0 otherwise
3484 sub is_ip {
3485     my $alleged_ip = shift;
3486
3487     # If we don't have four, . delimited numbers then we have no hope
3488     if (!defined $alleged_ip || $alleged_ip !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) {
3489         ld_log( _message('ERR0501') );
3490         return 0;
3491     }
3492
3493     # Each octet must be >=0 and <=255
3494     is_octet($1) or return 0;
3495     is_octet($2) or return 0;
3496     is_octet($3) or return 0;
3497     is_octet($4) or return 0;
3498
3499     return 1;
3500 }
3501
3502 # ip_to_int
3503 # Turn an IP address given as a dotted quad into an integer
3504 # pre: ip_address: string representing IP address
3505 # post: post ip_address is converted to an integer
3506 # return: -1 if an error occurs
3507 #         integer representation of IP address otherwise
3508 sub ip_to_int {
3509     my $ip_address = shift;
3510
3511     if ( !is_ip($ip_address) ) {
3512         return -1;
3513     }
3514     my ($oct1, $oct2, $oct3, $oct4)
3515         = $ip_address =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
3516
3517     my $result = ($oct1 << 24) + ($oct2 << 16) + ($oct3 << 8) + $oct4;
3518     return $result;
3519 }
3520
3521 # int_to_ip
3522 # Turn an IP address given as an integer into a dotted quad
3523 # pre: ip_address: integer representation of IP address
3524 # post: Decimal is converted to a dotted quad
3525 # return: string representing IP address
3526 sub int_to_ip {
3527     my $ip_address = shift;
3528     if (!defined $ip_address || $ip_address !~ /^\d+$/) {
3529         ld_log( _message('ERR0501') );
3530         return;
3531     }
3532
3533     my $result = sprintf "%d.%d.%d.%d",
3534                      ($ip_address >> 24) & 255,
3535                      ($ip_address >> 16) & 255,
3536                      ($ip_address >> 8 ) & 255,
3537                      ($ip_address      ) & 255;
3538     return $result;
3539 }
3540
3541 # get_ip_port
3542 # Get the service for a virtual or a real
3543 # pre: host: virtual or real to get the service for
3544 # post: none
3545 # return: ip_address:port
3546 sub get_ip_port {
3547     my ($host, $checkport) = @_;
3548     my $server = defined $host && defined $host->{server} && defined $host->{server}{ip}
3549                     ? $host->{server}{ip  } : q{};
3550     my $port   = defined $checkport ? $checkport
3551                : defined $host && defined $host->{server} && defined $host->{server}{port}
3552                     ? $host->{server}{port} : q{};
3553
3554     my $ip_port = $server ne q{} && $port ne q{} ? "$server:$port" : q{};
3555     return $ip_port;
3556 }
3557
3558 # get_health_check_id_str
3559 # Get an id string for a health check process
3560 # pre: r: Real service.
3561 #      v: Virtual service
3562 # post: none
3563 # return: Id string for the health check process
3564 sub get_health_check_id_str {
3565     my ($v, $r) = @_;
3566     if ( !defined $v || !defined $r || !defined $r->{server} ) {
3567         ld_log( _message('ERR0501') );
3568         return;
3569     }
3570
3571     my $ip   = defined $r->{server}{ip  } ? $r->{server}{ip  } : q{};
3572     my $port = defined $v->{checkport   } ? $v->{checkport   } :
3573                defined $r->{server}{port} ? $r->{server}{port} : q{};
3574     my $checktype    = defined $v->{checktype   } ? $v->{checktype   } : q{};
3575     my $service      = defined $v->{service     } ? $v->{service     } : q{};
3576     my $protocol     = defined $v->{protocol    } ? $v->{protocol    } : q{};
3577     my $num_connects = defined $v->{num_connects} ? $v->{num_connects} : q{};
3578     my $request      = defined $r->{request     } ? $r->{request     } : q{};
3579     my $receive      = defined $r->{receive     } ? $r->{receive     } : q{};
3580     my $httpmethod   = defined $v->{httpmethod  } ? $v->{httpmethod  } : q{};
3581     my $virtualhost  = defined $v->{virtualhost } ? $v->{virtualhost } : q{};
3582     my $login        = defined $v->{login       } ? $v->{login       } : q{};
3583     my $password     = defined $v->{passwd      } ? $v->{passwd      } : q{};
3584     my $database     = defined $v->{database    } ? $v->{database    } : q{};
3585     my $customcheck  = defined $v->{customcheck } ? $v->{customcheck } : q{};
3586     my $checkinterval    = defined $v->{checkinterval    } ? $v->{checkinterval    } : q{};
3587     my $checkcount       = defined $v->{checkcount       } ? $v->{checkcount       } : q{};
3588     my $checktimeout     = defined $v->{checktimeout     } ? $v->{checktimeout     } : q{};
3589     my $negotiatetimeout = defined $v->{negotiatetimeout } ? $v->{negotiatetimeout } : q{};
3590     my $retryinterval    = defined $v->{retryinterval    } ? $v->{retryinterval    } : q{};
3591
3592     # FIXME SHOULD change separator. (request, receive, login, passwd ,database may include ':')
3593     my $id = "$ip:$port:$checktype:$service:$protocol:$num_connects:$request:$receive:" .
3594              "$httpmethod:$virtualhost:$login:$password:$database:$customcheck:" .
3595              "$checkinterval:$checkcount:$checktimeout:$negotiatetimeout:$retryinterval";
3596
3597     return $id;
3598 }
3599
3600 # get_virtual_id_str
3601 # Get an id string for a virtual service
3602 # pre: v: Virtual service
3603 # post: none
3604 # return: Id string for the virtual service
3605 sub get_virtual_id_str {
3606     my $v = shift;
3607     if ( !defined $v || !defined $v->{module} ) {
3608         ld_log( _message('ERR0501') );
3609         return;
3610     }
3611
3612     my $ip_port     = get_ip_port($v);
3613     my $protocol    = defined $v->{protocol    } ? $v->{protocol    } : q{};
3614     my $module_name = defined $v->{module}{name} ? $v->{module}{name} : q{};
3615     my $module_key  = defined $v->{module}{key } ? $v->{module}{key } : q{};
3616
3617     my $id = "$protocol:$ip_port:$module_name $module_key";
3618     $id =~ s/ +$//;
3619
3620     return $id;
3621     # [cf] id = "tcp:127.0.0.1:80:cinsert --cookie-name 'monkey'"
3622 }
3623
3624 # get_forward_flag
3625 # Get the l7vsadm flag corresponging to a forwarding mechanism
3626 # pre: forward: Name of forwarding mechanism.
3627 #               Should be masq
3628 # post: none
3629 # return: l7vsadm flag corresponding to the forwading mechanism
3630 #         " " if $forward is unknown
3631 sub get_forward_flag {
3632     my $forward = shift;
3633
3634     if (defined $forward && $forward =~ /^masq$/i) {
3635         return '-m';
3636     }
3637     return q{};
3638 }
3639
3640 # ld_exit
3641 # Exit and log a message
3642 # pre: exit_status: Integer exit status to exit with
3643 #                   0 wiil be used if parameter is omitted
3644 #      message: Message to log when exiting. May be omitted
3645 # post: If exit_status is non-zero or $DEBUG_LEVEL>2 then
3646 #       message logged.
3647 #       Programme exits with exit_status
3648 # return: does not return
3649 sub ld_exit {
3650     my ($exit_status, $message) = @_;
3651     if (defined $exit_status && defined $message) {
3652         ld_log( _message('INF0006', $exit_status, $message) );
3653     }
3654     exit $exit_status;
3655 }
3656
3657 # ld_open_socket
3658 # Open a socket connection
3659 # pre: remote: IP address as a dotted quad of remote host to connect to
3660 #      port: port to connect to
3661 #      protocol: Prococol to use. Should be either "tcp" or "udp"
3662 # post: A Socket connection is opened to the remote host
3663 # return: Open socket
3664 sub ld_open_socket {
3665     require IO::Socket::INET;
3666     my ($remote, $port, $protocol, $timeout) = @_;
3667
3668     my $sock_handle = IO::Socket::INET->new(
3669             PeerAddr => $remote,
3670             PeerPort => $port,
3671             Proto    => $protocol,
3672             Timeout  => $timeout,
3673         );
3674     return $sock_handle;
3675 }
3676
3677 # daemon
3678 # Close and fork to become a daemon.
3679 #
3680 # Notes from unix programmer faq
3681 # http://www.landfield.com/faqs/unix-faq/programmer/faq/
3682 #
3683 # Almost none of this is necessary (or advisable) if your daemon is being
3684 # started by `inetd'.  In that case, stdin, stdout and stderr are all set up
3685 # for you to refer to the network connection, and the `fork()'s and session
3686 # manipulation should *not* be done (to avoid confusing `inetd').  Only the
3687 # `chdir()' step remains useful.
3688 sub ld_daemon {
3689     ld_daemon_become_child();
3690
3691     if (POSIX::setsid() < 0) {
3692         ld_exit( 7, _message_only('ERR0702') );
3693     }
3694
3695     ld_daemon_become_child();
3696
3697     if (chdir('/') < 0) {
3698         ld_exit( 8, _message_only('ERR0703') );
3699     }
3700
3701     close *STDIN;
3702     close *STDOUT;
3703     close *STDERR;
3704
3705     eval { open  *STDIN, '<', '/dev/null'; };
3706     ld_exit(9, _message_only('ERR0704') ) if ($EVAL_ERROR);
3707     eval { open *STDOUT, '>>', '/dev/console'; };
3708     ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
3709     eval { open *STDERR, '>>', '/dev/console'; };
3710     ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
3711 }
3712
3713 # ld_daemon_become_child
3714 # Fork, kill parent and return child process
3715 # pre: none
3716 # post: process forkes and parent exits
3717 #       All preocess exit with exit status -1 if an error occurs
3718 # return: parent: exits
3719 #         child: none  (this is the process that returns)
3720 sub ld_daemon_become_child {
3721     my $status = fork();
3722     $PROC_STAT{pid} = $PID;
3723
3724     if ($status < 0) {
3725         ld_exit( 6, _message_only('ERR0701', $ERRNO) );
3726     }
3727     if ($status > 0) {
3728         ld_exit( 0, _message_only('INF0005') );
3729     }
3730 }
3731
3732 # ld_gethostbyname
3733 # Wrapper to gethostbyname. Look up the/an IP address of a hostname
3734 # If an IP address is given is it returned
3735 # pre: name: Hostname of IP address to lookup
3736 # post: gethostbyname is called to find an IP address for $name
3737 #       This is converted to a string
3738 # return: IP address
3739 #         undef on error
3740 sub ld_gethostbyname {
3741     my $name = shift;
3742     $name = q{} if !defined $name;
3743     my $addrs = ( gethostbyname($name) )[4] or return;
3744     return Socket::inet_ntoa($addrs);
3745 }
3746
3747 # ld_getservbyname
3748 # Wraper for getservbyname. Look up the port for a service name
3749 # If a port is given it is returned.
3750 # pre: name: Port or Service name to look up
3751 # post: if $name is a number
3752 #         if 0<=$name<=65536 $name is returned
3753 #         else undef is returned
3754 #       else getservbyname is called to look up the port for the service
3755 # return: Port
3756 #         undef on error
3757 sub ld_getservbyname {
3758     my ($name, $protocol) = @_;
3759     $name     = q{} if !defined $name;
3760     $protocol = q{} if !defined $protocol;
3761
3762     if ($name =~ /^\d+$/) {
3763         if ($name > 65535) {
3764             return;
3765         }
3766         return $name;
3767     }
3768
3769     my $port = ( getservbyname($name, $protocol) )[2];
3770     return $port;
3771 }
3772
3773 # ld_gethostservbyname
3774 # Wraper for ld_gethostbyname and ld_getservbyname. Given a server of the
3775 # form ip_address|hostname:port|servicename return hash refs of ip_address and port
3776 # pre: hostserv: Servver of the form ip_address|hostname:port|servicename
3777 #      protocol: Protocol for service. Should be either "tcp" or "udp"
3778 # post: lookups performed as per ld_getservbyname and ld_gethostbyname
3779 # return: { ip => ip_address, port => port }
3780 #         undef on error
3781 sub ld_gethostservbyname {
3782     my ($hostserv, $protocol) = @_;
3783
3784     if (!defined $hostserv || $hostserv !~ /
3785             ^
3786             (\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+) # host or ip
3787             :                                # colon
3788             (\d+|[a-z0-9-]+)                 # serv or port
3789             $
3790         /ix) {
3791         return;
3792     }
3793     my $ip   = $1;
3794     my $port = $2;
3795     $ip   = ld_gethostbyname($ip) or return;
3796     $port = ld_getservbyname($port, $protocol);
3797     return if !defined $port;
3798
3799     return {ip => $ip, port => $port};
3800 }
3801
3802 # _message_only
3803 # Create message only.
3804 sub _message_only {
3805     my ($code, @message_args) = @_;
3806
3807     my $message_list = {
3808         # health check process exit
3809         FTL0001 => "health_check argument is invalid. Exit this monitor process with status: 1",
3810         FTL0002 => "health_check argument pair, virtual or real structure is invalid. Exit this monitor process with status: 2",
3811         FTL0003 => "Detected down management process (pid: %s). Exit this monitor process with status: 3",
3812         # file fatal error
3813         FTL0101 => "l7vsadm file `%s' is not found or cannot execute.",
3814         FTL0102 => "Config file is not defined. So cannot check configuration change.",
3815         FTL0103 => "Cannot open logfile `%s'. Log message: `%s'",
3816         # command fatal error
3817         FTL0201 => "Result of read from l7vsadm is not defined.",
3818
3819         # exit
3820         ERR0001 => "Initialization error: %s",
3821         ERR0002 => "Configuration error and exit.",
3822         # validation error
3823         ERR0101 => "Invalid value (set natural number) `%s'.",
3824         ERR0102 => "Invalid value (set `yes' or `no') `%s'.",
3825         ERR0103 => "Invalid value (set any word) `%s'.",
3826         ERR0104 => "Invalid value (set `custom', `connect', `negotiate', `ping', `off', `on' "
3827                  . "or positive number) `%s'.",
3828         ERR0105 => "Invalid value (set `lc', `rr' or `wrr') `%s'.",
3829         ERR0106 => "Invalid value (set `http', `https', `ftp', `smtp', `pop', `imap', "
3830                  . "`ldap', `nntp', `dns', `mysql', `pgsql', `sip', or `none') `%s'.",
3831         ERR0107 => "Invalid value (forwarding mode must be `masq') `%s'.",
3832         ERR0108 => "Invalid port number `%s'.",
3833         ERR0109 => "Invalid protocol (protocol must be `tcp') `%s'.",
3834         ERR0110 => "Invalid HTTP method (set `GET' or `HEAD') `%s'.",
3835         ERR0111 => "Invalid module (set `url', `pfilter', `ip', `sslid' or `sessionless') `%s'.",
3836         # ERR0111 => "Invalid module (set `cinsert', `cpassive', `crewrite', `url', `pfilter', `ip', `sslid' or `sessionless') `%s'.",
3837         ERR0112 => "Invalid module key option (`%s' module must set `%s' option) `%s'.",
3838         ERR0113 => "Invalid QoS value (set 0 or 1-999[KMG]. must specify unit(KMG)) `%s'.",
3839         ERR0114 => "Invalid address `%s'.",
3840         ERR0115 => "Invalid address range (first value(%s) must be less than or equal to the second value(%s)) `%s'.",
3841         ERR0116 => "File not found `%s'.",
3842         ERR0117 => "File not found or cannot execute `%s'.",
3843         ERR0118 => "Unable to open logfile `%s'.",
3844         ERR0119 => "Virtual section not found for `%s'.",
3845         ERR0120 => "Unknown config `%s'.",
3846         ERR0121 => "Configuration error. Reading file `%s' at line %d: %s",
3847         ERR0122 => "Caught exception during re-read config file and re-setup l7vsd. (message: %s) "
3848                  . "So config setting will be rollbacked.",
3849         ERR0123 => "`%s' is a required module for checking %s service.",
3850         # operate l7vsd error
3851         ERR0201 => "Failed to add virtual service to l7vsd: `%s %s', output: `%s'",
3852         ERR0202 => "Failed to edit virtual service on l7vsd: `%s %s', output: `%s'",
3853         ERR0203 => "Failed to delete virtual service from l7vsd: `%s %s', output: `%s'",
3854         ERR0204 => "Failed to add server to l7vsd: `%s' ( x `%s %s'), output: `%s'",
3855         ERR0205 => "Failed to edit server on l7vsd: `%s' ( x `%s %s'), output: `%s'",
3856         ERR0206 => "Failed to delete server from l7vsd: `%s' ( x `%s %s'), output: `%s'",
3857         ERR0207 => "Trying add server `%s', but virtual service `%s' is not found.",
3858         ERR0208 => "Trying delete server `%s', but virtual service `%s' is not found.",
3859         ERR0209 => "`%s' was already existed on l7vsd. ( x `%s %s')",
3860         ERR0210 => "`%s' was already deleted on l7vsd. ( x `%s %s')",
3861         ERR0211 => "`%s' was already changed to quiescent state on l7vsd. ( x `%s %s')",
3862         # command error
3863         ERR0301 => "Failed to system `%s' with return: %s",
3864         ERR0302 => "Failed to exec `%s' with return: %s",
3865         ERR0303 => "Failed to command `%s' with return: %s",
3866         # file error
3867         ERR0401 => "Failed to delete file `%s': `Is a directory'",
3868         ERR0402 => "Failed to delete file `%s': `No such file'",
3869         ERR0403 => "Failed to delete file `%s': `%s'",
3870         ERR0404 => "Config file `%s' is not found.",
3871         ERR0405 => "`l7directord.cf' is not found at default search paths.",
3872         ERR0406 => "`l7vsadm' file is not found at default search paths.",
3873         ERR0407 => "Cannot open config file `%s'.",
3874         ERR0408 => "Cannot close config file `%s'.",
3875         ERR0409 => "Cannot open pid file (%s): %s",
3876         ERR0410 => "Cannot get mtime of configuration file `%s'",
3877         ERR0411 => "No delete file specified.",
3878         ERR0412 => "Invalid pid specified. (pid: %s)",
3879         # undefined
3880         ERR0501 => "Some method arguments are undefined.",
3881         ERR0502 => "VirtualService ID is undefined.",
3882         ERR0503 => "HealthCheck ID is undefined.",
3883         ERR0504 => "negotiate function is undefined. So use check_connect function.",
3884         ERR0505 => "custom check script is undefined. So use check_off function.",
3885         # health check process
3886         ERR0601 => "Service up detected. (Real server `%s')",
3887         ERR0602 => "Service down detected. (Real server `%s')",
3888         ERR0603 => "Detected down monitor process (pid: %s). Prepare to re-start health check process. (id: `%s')",
3889         ERR0604 => "Failed to fork() on sub process creation. (id: `%s')",
3890         # daemon
3891         ERR0701 => "Cannot fork for become daemon (errno: `%s') and exit.",
3892         ERR0702 => "Cannot setsid for become daemon and exit.",
3893         ERR0703 => "Cannot chdir for become daemon and exit.",
3894         ERR0704 => "Cannot open /dev/null for become daemon and exit.",
3895         ERR0705 => "Cannot open /dev/console for become daemon and exit.",
3896
3897         # signal
3898         WRN0001 => "l7directord `%s' received signal: %s. Terminate process.",
3899         WRN0002 => "l7directord `%s' received signal: %s. Reload configuration.",
3900         WRN0003 => "Signal TERM send error(pid: %d)",
3901         WRN0004 => "Signal HUP send error(pid: %d)",
3902         # config
3903         WRN0101 => "Configuration file `%s' has changed on disk.",
3904         WRN0102 => "Reread new configuration.",
3905         WRN0103 => "Ignore new configuration.",
3906         # service check OK
3907         WRN0203 => "Service check OK. HTTP response is valid. HTTP response status line is `%s' (real - `%s:%s')",
3908         WRN0204 => "Service check OK. Successfully connect SMTP server. (real - `%s:%s')",
3909         WRN0205 => "Service check OK. Successfully connect POP3 server. (real - `%s:%s')",
3910         WRN0206 => "Service check OK. Successfully connect IMAP server. (real - `%s:%s')",
3911         WRN0207 => "Service check OK. Successfully bind LDAP server. (real - `%s:%s')",
3912         WRN0208 => "Service check OK. NNTP response is valid. `%s' (real - `%s:%s')",
3913         WRN0209 => "Service check OK. Database response is valid. (real - `%s:%s')",
3914         WRN0210 => "Service check OK. Successfully connect socket to server. (real - `%s:%s')",
3915         WRN0211 => "Service check OK. SIP response is valid. `%s' (real - `%s:%s')",
3916         WRN0212 => "Service check OK. Successfully login FTP server. (real - `%s')",
3917         WRN0213 => "Service check OK. Successfully lookup DNS. (real - `%s:%s')",
3918         WRN0214 => "Service check OK. Successfully receive ping response. (real - `%s')",
3919         WRN0215 => "Custom check result OK. (real - `%s')",
3920         # perl warn
3921         WRN0301 => "Perl warning: `%s'",
3922         # service check NG
3923         WRN1001 => "Retry service check `%s' %d more time(s).",
3924         # - http
3925         WRN1101 => "Service check NG. Check URL `%s' is not valid. (real - `%s:%s')",
3926         WRN1102 => "Service check NG. HTTP response is not ok. Response status line is `%s' (real - `%s:%s')",
3927         WRN1103 => "Service check NG. Check string `%s' is not found in HTTP response. (real - `%s:%s')",
3928         # - smtp
3929         WRN1201 => "Service check NG. Cannot connect SMTP server. (real - `%s:%s')",
3930         # - pop3
3931         WRN1301 => "Service check NG. Cannot connect POP3 server. (real - `%s:%s')",
3932         WRN1302 => "Service check NG. Cannot login POP3 server. (real - `%s:%s')",
3933         # - imap
3934         WRN1401 => "Service check NG. Cannot connect IMAP server. (real - `%s:%s')",
3935         WRN1402 => "Service check NG. Cannot login IMAP server. (real - `%s:%s')",
3936         WRN1403 => "Service check NG. Connection timeout from IMAP server in %d seconds. (real - `%s:%s')",
3937         # - ldap
3938         WRN1501 => "Service check NG. Cannot connect LDAP server. (real - `%s:%s')",
3939         WRN1502 => "Service check NG. Connection timeout from LDAP server in %d seconds. (real - `%s:%s')",
3940         WRN1503 => "Service check NG. LDAP bind error. (real - `%s:%s')",
3941         WRN1504 => "Service check NG. Exists %d results (not one) on search Base DN. (real - `%s:%s')",
3942         WRN1505 => "Service check NG. Check string `%s' is not found in Base DN search result. (real - `%s:%s')",
3943         # - nntp
3944         WRN1601 => "Service check NG. Cannot connect NNTP server. (real - `%s:%s')",
3945         WRN1602 => "Service check NG. Connection timeout from NNTP server in %d seconds. (real - `%s:%s')",
3946         WRN1603 => "Service check NG. NNTP response is not ok. `%s' (real - `%s:%s')",
3947         # - sql
3948         WRN1701 => "Service check NG. SQL check must set `database', `login', `passwd' by configuration. (real - `%s:%s')",
3949         WRN1702 => "Service check NG. Cannot connect database or cannot login database. (real - `%s:%s')",
3950         WRN1703 => "Service check NG. Query result has no row. (real - `%s:%s')",
3951         WRN1704 => "Service check NG. Expected %d rows of query results, but got %d rows. (real - `%s:%s')",
3952         WRN1705 => "Service check NG. Connection timeout from database in %d seconds. (real - `%s:%s')",
3953         # - sip
3954         WRN1801 => "Service check NG. SIP check must set `login' by configuration. (real - `%s:%s')",
3955         WRN1802 => "Service check NG. Cannot connect SIP server. (real - `%s:%s')",
3956         WRN1803 => "Service check NG. SIP response is not ok. `%s' (real - `%s:%s')",
3957         WRN1804 => "Service check NG. Connection timeout from SIP server in %d seconds. (real - `%s:%s')",
3958         # - ftp
3959         WRN1901 => "Service check NG. FTP check must set `login', `passwd' by configuration. (real - `%s')",
3960         WRN1902 => "Service check NG. Cannot connect FTP server. (real - `%s')",
3961         WRN1903 => "Service check NG. Cannot login FTP server. (real - `%s')",
3962         WRN1904 => "Service check NG. Cannot chdir to / of FTP server. (real - `%s')",
3963         WRN1905 => "Service check NG. Cannot get file `%s' (real - `%s')",
3964         WRN1906 => "Service check NG. Check string `%s' is not found in file `%s' (real - `%s')",
3965         WRN1907 => "Service check NG. Exception occur during FTP check `%s' (real - `%s')",
3966         WRN1908 => "Service check NG. Connection timeout from FTP server in %d seconds. (real - `%s')",
3967         # - dns
3968         WRN2001 => "Service check NG. DNS check must set `request', `receive' by configuration. (real - `%s:%s')",
3969         WRN2002 => "Service check NG. Connection timeout from DNS server in %d seconds. (real - `%s:%s')",
3970         WRN2003 => "Service check NG. Net::DNS exception occur `%s' (real - `%s:%s')",
3971         WRN2004 => "Service check NG. DNS search `%s' not respond. (real - `%s:%s')",
3972         WRN2005 => "Service check NG. Check string `%s' is not found in search result. (real - `%s:%s')",
3973         # - ping
3974         WRN3101 => "Service check NG. Ping timeout in %d seconds. (real - `%s')",
3975         # - connect
3976         WRN3201 => "Service check NG. Cannot connect socket to server. (errno: `%s') (real - `%s:%s')",
3977         # - custom
3978         WRN3301 => "Custom check NG. Check timeout in %d seconds. (real - `%s')",
3979         WRN3302 => "Custom check NG. `%s' returns %d",
3980
3981         # start stop
3982         INF0001 => "Starting program with command: `%s'",
3983         INF0002 => "Starting l7directord v%s with pid: %d (configuration: `%s')",
3984         INF0003 => "Starting l7directord v%s as daemon. (configuration: `%s')",
3985         INF0004 => "Exit by initialize error.",
3986         INF0005 => "Exit parent process for become daemon",
3987         INF0006 => "Exiting with exit status %d: %s",
3988         INF0007 => "Detected halt flag. Exit this monitor process with status: 0",
3989         INF0008 => "Reached end of `main'",
3990         # stderr
3991         INF0101 => "l7directord for `%s' is running with pid: %d",
3992         INF0102 => "l7directord stale pid file %s for %s",
3993         INF0103 => "Other l7directord process is running. (pid: %d)",
3994         INF0104 => "l7directord process is not running.",
3995         # l7vsd
3996         INF0201 => "Add virtual service to l7vsd: `%s %s'",
3997         INF0202 => "Edit virtual service on l7vsd: `%s %s'",
3998         INF0203 => "Delete virtual service from l7vsd: `%s %s'",
3999         INF0204 => "Add server to l7vsd: `%s' ( x `%s %s') (weight set to %d)",
4000         INF0205 => "Edit server on l7vsd: `%s' ( x `%s %s') (weight set to %d)",
4001         INF0206 => "Delete server from l7vsd: `%s' ( x `%s %s')",
4002         # server change
4003         INF0301 => "Added real server. (`%s')",
4004         INF0302 => "Added fallback server. (`%s')",
4005         INF0303 => "Changed real server to quiescent state. (`%s')",
4006         INF0304 => "Changed fallback server to quiescent state. (`%s')",
4007         INF0305 => "Deleted real server. (`%s')",
4008         INF0306 => "Deleted fallback server. (`%s')",
4009         # health check
4010         INF0401 => "Prepare to start health check process. (id: `%s')",
4011         INF0402 => "Create health check process with pid: %d. (id `%s')",
4012         # run
4013         INF0501 => "Real server down shell execute: `%s %s'",
4014         INF0502 => "Real server recovery shell execute: `%s %s'",
4015         INF0503 => "Config callback shell execute: `%s %s'",
4016         INF0504 => "Running system: `%s'",
4017         INF0505 => "Running exec: `%s'",
4018         INF0506 => "Running command: `%s'",
4019         };
4020
4021     my $message
4022         = exists $message_list->{$code} ? sprintf $message_list->{$code}, @message_args
4023         : "Unknown message. (code:[$code] args:[" . join(q{, }, @message_args) . '])';
4024
4025     return $message;
4026 }
4027
4028 # _message
4029 # Create message by _message_only and add code header.
4030 sub _message {
4031     my ($code, @message_args) = @_;
4032     my $message = _message_only($code, @message_args);
4033     $message = "[$code] $message";
4034     return $message;
4035 }
4036
4037 1;
4038
4039 __END__
4040
4041 =head1 NAME
4042
4043 l7directord - UltraMonkey-L7 Director Daemon
4044
4045 Daemon to monitor remote services and control UltraMonkey-L7
4046
4047
4048 =head1 SYNOPSIS
4049
4050 B<l7directord> [B<-d>] [I<configuration>] {B<start>|B<stop>|B<restart>|B<try-restart>|B<reload>|B<status>|B<configtest>}
4051
4052 B<l7directord> B<-t> [I<configuration>]
4053
4054 B<l7directord> B<-h|--help>
4055
4056 B<l7directord> B<-v|--version>
4057
4058 =head1 DESCRIPTION
4059
4060 B<l7directord> is a daemon to monitor and administer real servers in a
4061 cluster of load balanced virtual servers. B<l7directord> is similar to B<ldirectord>
4062 in terms of functionality except that it triggers B<l7vsadm>.
4063 B<l7directord> typically is started from command line but can be included
4064 to start from heartbeat. On startup B<l7directord> reads the file
4065 B</etc/ha.d/conf/>I<configuration>.
4066 After parsing the file, entries for virtual servers are created on the UltraMonkey-L7.
4067 Now at regular intervals the specified real servers are monitored and if
4068 they are considered alive, added to a list for each virtual server. If a
4069 real server fails, it is removed from that list. Only one instance of
4070 B<l7directord> can be started for each configuration, but more instances of
4071 B<l7directord> may be started for different configurations. This helps to
4072 group clusters of services.  This can be done by putting an entry inside
4073 B</etc/ha.d/haresources>
4074
4075 I<nodename virtual-ip-address l7directord::configuration>
4076
4077 to start l7directord from heartbeat.
4078
4079
4080 =head1 OPTIONS
4081
4082 =over
4083
4084 =item I<configuration>:
4085
4086 This is the name for the configuration as specified in the file
4087 B</etc/ha.d/conf/>I<configuration>
4088
4089 =item B<-d>
4090
4091 Don't start as daemon. Useful for debugging.
4092
4093 =item B<-h>
4094
4095 Help. Print user manual of l7directord.
4096
4097 =item B<-v>
4098
4099 Version. Print version of l7directord.
4100
4101 =item B<-t>
4102
4103 Run syntax tests for configuration files only. The program immediately exits after these syntax parsing tests
4104 with either a return code of 0 (Syntax OK) or return code not equal to 0 (Syntax Error).
4105
4106 =item B<start>
4107
4108 Start the daemon for the specified configuration.
4109
4110 =item B<stop>
4111
4112 Stop the daemon for the specified configuration. This is the same as sending
4113 a TERM signal to the running daemon.
4114
4115 =item B<restart>
4116
4117 Restart the daemon for the specified configuration. The same as stopping and starting.
4118
4119 =item B<try-restart>
4120
4121 Try to restart the daemon for the specified configuration. If l7directord is already running for the
4122 specified configuration, then the same is stopped and started (Similar to restart).
4123 However, if l7directord is not already running for the specified configuration, then an error message
4124 is thrown and the program exits.
4125
4126 =item B<reload>
4127
4128 Reload the configuration file. This is only useful for modifications
4129 inside a virtual server entry. It will have no effect on adding or
4130 removing a virtual server block. This is the same as sending a HUP signal to
4131 the running daemon.
4132
4133 =item B<status>
4134
4135 Show status of the running daemon for the specified configuration.
4136
4137 =item B<configtest>
4138
4139 This is the same as B<-t>.
4140
4141 =back
4142
4143
4144 =head1 SYNTAX
4145
4146 =head2 Description how to write configuration files
4147
4148 =over
4149
4150 =item B<virtual = >I<(ip_address|hostname:portnumber|servicename)>
4151
4152 Defines a virtual service by IP-address (or hostname) and port (or
4153 servicename). All real services and flags for a virtual
4154 service must follow this line immediately and be indented.
4155 For ldirectord, Firewall-mark settings could be set. But for l7directord
4156 Firewall-mark settings cannot be set.
4157
4158 =item B<checktimeout = >I<n>
4159
4160 Timeout in seconds for connect checks. If the timeout is exceeded then the
4161 real server is declared dead.  Default is 5 seconds. If defined in virtual
4162 server section then the global value is overridden.
4163
4164 =item B<negotiatetimeout = >I<n>
4165
4166 Timeout in seconds for negotiate checks. Default is 5 seconds.
4167 If defined in virtual server section then the global value is overridden.
4168
4169 =item B<checkinterval = >I<n>
4170
4171 Defines the number of second between server checks. Default is 10 seconds.
4172 If defined in virtual server section then the global value is overridden.
4173
4174 =item B<retryinterval = >I<n>
4175
4176 Defines the number of second between server checks when server status is NG.
4177 Default is 10 seconds. If defined in virtual server section then the global
4178 value is overridden.
4179
4180 =item B<checkcount = >I<n>
4181
4182 The number of times a check will be attempted before it is considered
4183 to have failed. Note that the checktimeout is additive, so if checkcount
4184 is 3 and checktimeout is 2 seconds and retryinterval is 1 second,
4185 then a total of 8 seconds (2 + 1 + 2 + 1 + 2) worth of timeout will occur
4186 before the check fails. Default is 1. If defined in virtual server section
4187 then the global value is overridden.
4188
4189 =item B<configinterval = >I<n>
4190
4191 Defines the number of second between configuration checks.
4192 Default is 5 seconds.
4193
4194 =item B<autoreload = >[B<yes>|B<no>]
4195
4196 Defines if <l7directord> should continuously check the configuration file
4197 for modification each B<configinterval> seconds. If this is set to B<yes>
4198 and the configuration file changed on disk and its modification time (mtime)
4199 is newer than the previous version, the configuration is automatically reloaded.
4200 Default is B<no>.
4201
4202 =item B<callback = ">I</path/to/callback>B<">
4203
4204 If this directive is defined, B<l7directord> automatically calls
4205 the executable I</path/to/callback> after the configuration
4206 file has changed on disk. This is useful to update the configuration
4207 file through B<scp> on the other heartbeated host. The first argument
4208 to the callback is the name of the configuration.
4209
4210 This directive might also be used to restart B<l7directord> automatically
4211 after the configuration file changed on disk. However, if B<autoreload>
4212 is set to B<yes>, the configuration is reloaded anyway.
4213
4214 =item B<fallback = >I<ip_address|hostname[:portnumber|servicename]> [B<masq>]
4215
4216 the server onto which a web service is redirected if all real
4217 servers are down. Typically this would be 127.0.0.1 with
4218 an emergency page.
4219
4220 This directive may also appear within a virtual server, in which
4221 case it will override the global fallback server, if set.
4222 Only a value of B<masq> can be specified here. The default is I<masq>.
4223
4224 =item B<logfile = ">I</path/to/logfile>B<">|syslog_facility
4225
4226 An alternative logfile might be specified with this directive. If the logfile
4227 does not have a leading '/', it is assumed to be a syslog(3) facility name.
4228
4229 The default is to log directly to the file I</var/log/l7vs/l7directord.log>.
4230
4231 =item B<execute = ">I<configuration>B<">
4232
4233 Use this directive to start an instance of l7directord for
4234 the named I<configuration>.
4235
4236 =item B<supervised>
4237
4238 If this directive is specified, the daemon does not go into background mode.
4239 All log-messages are redirected to stdout instead of a logfile.
4240 This is useful to run B<l7directord> supervised from daemontools.
4241 See http://untroubled.org/rpms/daemontools/ or http://cr.yp.to/daemontools.html
4242 for details.
4243
4244 =item B<quiescent = >[B<yes>|B<no>]
4245
4246 If B<yes>, then when real or fallback servers are determined
4247 to be down, they are not actually removed from the UltraMonkey-L7,
4248 but set weight to zero.
4249 If B<no>, then the real or fallback servers will be removed
4250 from the UltraMonkey-L7. The default is B<yes>.
4251
4252 This directive may also appear within a virtual server, in which
4253 case it will override the global fallback server, if set.
4254
4255 =back
4256
4257
4258 =head2 Section virtual
4259
4260 The following commands must follow a B<virtual> entry and must be indented
4261 with a minimum of 4 spaces or one tab.
4262
4263 =over
4264
4265 =item B<real => I<ip_address|hostname[-E<gt>ip_address|hostname][:portnumber|servicename>] [B<masq>] [I<n>] [B<">I<request>B<", ">I<receive>B<">]
4266
4267 Defines a real service by IP-address (or hostname) and port (or
4268 servicename). If the port is omitted then a 0 will be used.
4269 Optionally a range of IP addresses (or two hostnames) may be
4270 given, in which case each IP address in the range will be treated as a real
4271 server using the given port. The second argument defines the forwarding
4272 method, it must be B<masq> only.  The third argument defines the weight of
4273 each real service. This argument is optional. Default is 1. The last two
4274 arguments are optional too. They define a request-receive pair to be used to
4275 check if a server is alive. They override the request-receive pair in the
4276 virtual server section. These two strings must be quoted. If the request
4277 string starts with I<http://...> the IP-address and port of the real server
4278 is overridden, otherwise the IP-address and port of the real server is used.
4279
4280 =item B<module => I<proto-module module-args [opt-module-args]>
4281
4282 Indicates the module parameter of B<l7directord>. Here B<proto-module>
4283 denotes the protocol module name (For example, pfilter). B<module-args> denotes the
4284 arguments for the protocol module (For example, --pattern-match '*.html*').
4285 B<module-args> is optional only when set B<sessionless>, B<ip> and B<sslid> module to B<proto-module>.
4286 The last argument is optional (For example, --reschedule).
4287
4288 =back
4289
4290 =head2 More than one of these entries may be inside a virtual section:
4291
4292 =over
4293
4294 =item B<maxconn => I<n>
4295
4296 Defines the maximum connection that the virtual service can handle. If the number of
4297 requests cross the maxconn limit, the requests would be redirected to the
4298 sorry server.
4299
4300 =item B<qosup => I<n>[B<K>|B<M>|B<G>]
4301
4302 Defines the bandwidth quota size in bps for up stream. If the number of the
4303 bandwidth is over the qosup limit, a packet to the virtual service will be delayed
4304 until the number of bandwidth become below the qosup limit.
4305 B<K>(kilo), B<M>(mega) and B<G>(giga) unit are available.
4306
4307 =item B<qosdown => I<n>[B<K>|B<M>|B<G>]
4308
4309 Defines the bandwidth quota size in bps for down stream. If the number of the
4310 bandwidth is over the qosdown limit, a packet to the client will be delayed
4311 until the number of bandwidth become below the qosdown limit.
4312 B<K>(kilo), B<M>(mega) and B<G>(giga) unit are available.
4313
4314 =item B<sorryserver =>I<ip_address|hostname[:portnumber|servicename]>
4315
4316 Defines a sorry server by IP-address (or hostname) and port (or
4317 servicename). Firewall-mark settings cannot be set.
4318 If the number of requests to the virtual service cross the maxconn limit, the requests would be
4319 redirected to the sorry server.
4320
4321 =item B<checktype = negotiate>|B<connect>|I<N>|B<ping>|B<custom>|B<off>|B<on>
4322
4323 Type of check to perform. Negotiate sends a request and matches a receive
4324 string. Connect only attempts to make a TCP/IP connection, thus the
4325 request and receive strings may be omitted.  If checktype is a number then
4326 negotiate and connect is combined so that after each N connect attempts one
4327 negotiate attempt is performed. This is useful to check often if a service
4328 answers and in much longer intervals a negotiating check is done. Ping
4329 means that ICMP ping will be used to test the availability of real servers.
4330 Ping is also used as the connect check for UDP services. Custom means that
4331 custom command will be used to test the availability of real servers.
4332 Off means no checking will take place and no real or fallback servers will
4333 be activated.  On means no checking will take place and real servers will
4334 always be activated. Default is I<negotiate>.
4335
4336 =item B<service = ftp>|B<smtp>|B<http>|B<pop>|B<nntp>|B<imap>|B<ldap>|B<https>|B<dns>|B<mysql>|B<pgsql>|B<sip>|B<none>
4337
4338 The type of service to monitor when using checktype=negotiate. None denotes
4339 a service that will not be monitored. If the port specified for the virtual
4340 server is 21, 25, 53, 80, 110, 119, 143, 389, 443, 3306, 5432 or 5060 then
4341 the default is B<ftp>, B<smtp>, B<dns>, B<http>, B<pop>, B<nntp>, B<imap>,
4342 B<ldap>, B<https>, B<mysql>, B<pgsql> or B<sip> respectively.  Otherwise the
4343 default service is B<none>.
4344
4345 =item B<checkport = >I<n>
4346
4347 Number of port to monitor. Sometimes check port differs from service port.
4348 Default is port specified for the real server.
4349
4350 =item B<request = ">I<uri to requested object>B<">
4351
4352 This object will be requested each checkinterval seconds on each real
4353 server.  The string must be inside quotes. Note that this string may be
4354 overridden by an optional per real-server based request-string.
4355
4356 For a DNS check this should the name of an A record, or the address
4357 of a PTR record to look up.
4358
4359 For a MySQL or PostgreSQL checks, this should be a SQL query.
4360 The data returned is not checked, only that the
4361 answer is one or more rows.  This is a required setting.
4362
4363 =item B<receive = ">I<regexp to compare>B<">
4364
4365 If the requested result contains this I<regexp to compare>, the real server
4366 is declared alive. The regexp must be inside quotes. Keep in mind that
4367 regexps are not plain strings and that you need to escape the special
4368 characters if they should as literals. Note that this regexp may be
4369 overridden by an optional per real-server based receive regexp.
4370
4371 For a DNS check this should be any one the A record's addresses or
4372 any one of the PTR record's names.
4373
4374 For a MySQL check, the receive setting is not used.
4375
4376 =item B<httpmethod = GET>|B<HEAD>
4377
4378 Sets the HTTP method, which should be used to fetch the URI specified in
4379 the request-string. GET is the method used by default if the parameter is
4380 not set. If HEAD is used, the receive-string should be unset.
4381
4382 =item B<virtualhost = ">I<hostname>B<">
4383
4384 Used when using a negotiate check with HTTP or HTTPS. Sets the host header
4385 used in the HTTP request.  In the case of HTTPS this generally needs to
4386 match the common name of the SSL certificate. If not set then the host
4387 header will be derived from the request url for the real server if present.
4388 As a last resort the IP address of the real server will be used.
4389
4390 =item B<login = ">I<username>B<">
4391
4392 Username to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
4393 For FTP, the default is anonymous. For POP and IMAP, the default is the
4394 empty string, in which case authentication will not be attempted.
4395 For a MySQL and PostgreSQL, the username must be provided.
4396
4397 For SIP the username is used as both the to and from address
4398 for an OPTIONS query. If unset it defaults to l7directord\@<hostname>,
4399 hostname is derived as per the passwd option below.
4400
4401 =item B<passwd = ">I<password>B<">
4402
4403 Password to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
4404 Default is for FTP is l7directord\@<hostname>, where hostname is the
4405 environment variable HOSTNAME evaluated at run time, or sourced from uname
4406 if unset. The default for all other services is an empty password, in the
4407 case of MySQL and PostgreSQL this means authentication will not be
4408 performed.
4409
4410 =item B<database = ">I<databasename>B<">
4411
4412 Database to use for MySQL and PostgreSQL servers, this is the database that
4413 the query (set by B<receive> above) will be performed against.  This is a
4414 required setting.
4415
4416 =item B<scheduler => I<scheduler_name>
4417
4418 Scheduler to be used by UltraMonkey-L7 for load balancing.
4419 The available schedulers are only B<lc> and B<rr>. The default is I<rr>.
4420
4421 =item B<protocol = tcp>
4422
4423 Protocol to be used. B<l7vsadm> supports only B<tcp>.
4424 Since the virtual is specified as an IP address and port, it would be tcp
4425 and will default to tcp.
4426
4427 =item B<realdowncallback = ">I</path/to/realdowncallback>B<">
4428
4429 If this directive is defined, B<l7directord> automatically calls
4430 the executable I</path/to/realdowncallback> after a real server's status
4431 changes to down. The first argument to the realdowncallback is the real
4432 server's IP-address and port (ip_address:portnumber).
4433
4434 =item B<realrecovercallback = ">I</path/to/realrecovercallback>B<">
4435
4436 If this directive is defined, B<l7directord> automatically calls
4437 the executable I</path/to/realrecovercallback> after a real server's status
4438 changes to up. The first argument to the realrecovercallback is the real
4439 server's IP-address and port (ip_address:portnumber).
4440
4441 =item B<customcheck = ">I<custom check command>B<">
4442
4443 If this directive is defined and set B<checktype> to custom, B<l7directord>
4444 exec custom command for real servers health checking. Only if custom command
4445 returns 0, real servers will change to up. Otherwise real servers will change
4446 to down. Custom check command has some macro string. See below.
4447
4448 =over
4449
4450 =item B<_IP_>
4451
4452 Change to real server IP address.
4453
4454 =item B<_PORT_>
4455
4456 Change to real server port number.
4457
4458 =back
4459
4460 =back
4461
4462
4463 =head1 FILES
4464
4465 B</etc/ha.d/conf/l7directord.cf>
4466
4467 B</var/log/l7vs/l7directord.log>
4468
4469 B</var/run/l7directord.>I<configuration>B<.pid>
4470
4471 B</etc/services>
4472
4473 =head1 SEE ALSO
4474
4475 L<l7vsadm>, L<heartbeat>
4476
4477
4478 =head1 AUTHORS
4479
4480 NTT COMWARE
4481
4482 =cut