l7directord/l7directord

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