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