handle require_once and include_once, allow single quotes

[old-projects.git] / muxdaemon / muxdaemon.pl

#!/usr/bin/perl -w

use Config::General;
use Data::Dumper;
use Getopt::Std;
use IO::Handle;
use POSIX qw(setsid setuid setgid);
use POSIX ":sys_wait_h";

use strict;


#################
## Global vars ##
#################

my $confile = '';
my %conf;
my %running;
my $reload_conf=0;
my $debug=0;
#For each process, uid and gid to set after fork
my %gid;
my %uid;

#For sheduler
#Number of launch, for each daemon
my %launches;
my %ratio_launch_prio;
my %last_schedule;

###############
## Functions ##
###############

sub sigHUP_handler{
    &debug_msg("got SIGHUP\n");
    $reload_conf=1;
}


#Read Configuration and init global vars
sub read_conf {
    my $file = shift;
    my $config = new Config::General( -file =>"$file",
                                      -AllowMultiOptions =>"yes",
                                      -LowerCaseNames =>"yes",);
    %conf = $config->getall;
    &debug_msg(Dumper(\%conf));
}


sub debug_msg(#){
    my $text=shift;
    print STDERR $text unless ($debug == 0);
}


sub init {

    if ($confile eq ""){
        my $path = `pwd`;
        chomp($path);
        if ($path){
            $confile="$path/muxdaemon.conf";
        }else{
            print STDERR "Error : unable to get working directory, $!\n";
            exit(1);
        }
    }

    my %opts;
    if ( not getopts('dhf:', \%opts) or $opts{'h'}) {
        print STDERR "\nThis is mail processing Daemon :\n",
                      "-h          - this help message\n",
                      "-f <file>   - use <file> as config file\n",
                      "-d          - debug mode\n";
        exit(1);
    }

    if ($opts{'f'}){
        if (-r "$opts{'f'}") {
            print STDERR "Using $opts{'f'} as config file\n";
            &read_conf("$opts{'f'}");
        } else {
            print STDERR "$opts{'f'} : not a valid config file\n";
            exit(1);
        }
    } else {
        print STDERR "Using $confile as config file\n";
        if (-r "$confile") {
            &read_conf("$confile");
        } else {
            print STDERR "No valid configuration file found, aborting\n";
            exit(1);
        }
    }

    if ($opts{'d'}){
        print STDERR "Running in debug mode ...\n";
        $debug = 1;
    }else{
        $debug = 0;
    }
}

#init useful variables for scheduler
sub init_sched(){
    foreach my $arg (keys %{$conf{'client'}}){
        $launches{$arg} = 0;
        $ratio_launch_prio{$arg} = 0;
        $last_schedule{$arg} = 0;
    }
}

#check configuration file
sub check_conf{
    &debug_msg("Salut\n");
    print STDERR "Checking configuration file for wrong user/groups, schedules, ....\n";
    foreach my $arg (keys %{$conf{'client'}}){
        #La conf du client courant
        my %hash = %{$conf{'client'}{$arg}};
        if ($hash{'run_as_user'}) {
            my $id = getpwnam($hash{'run_as_user'});
            if ($id){
               $conf{'client'}{$arg}{'uid'} = $id;
            } else {
               print STDERR "  Error, user $hash{'run_as_user'} does not exist, please check...\n";
               exit(1);
            }
        }
        if ($hash{'run_as_group'}){
            my $id = getgrnam("$hash{'run_as_group'}");
            if ($id){
               $conf{'client'}{$arg}{'gid'} = $id;
            } else {
               print STDERR "  Error, group $hash{'run_as_group'} does not exist, please check...\n";
               exit(1);
            }
        }
        if ($hash{'allow_many'} eq "yes" and $hash{'min_schedule'}){
            print STDERR "  Error, allow_many and min_schedule defined for $arg\n";
            exit(1);
        }
    }
}


#make the program run in daemon mode
sub daemonize {
    print STDERR "Forking ... \n";
    chdir '/' or die "Can't chdir to /: $!";
    open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
    open STDOUT, '>>/dev/null' or die "Can't write to /dev/null: $!";
    if ($conf{'error_log'}){
        open STDERR, ">>$conf{'error_log'}" or die "Can't write to $conf{'error_log'}: $!";
    }else{
        open STDERR, '>>/dev/null' or die "Can't write to /dev/null: $!";
    }
    defined(my $pid = fork) or die "Can't fork: $!";
    exit if $pid;
    setsid or die "Can't start a new session: $!";
    #umask 0;
    &debug_msg("Daemon started\n");
}


#returns current load or any good value
sub get_load {
     my $load = 100;
     if (open(LOAD, '</proc/loadavg')) {
          my $line = <LOAD>;
          ($load) = ($line =~ m/(\d+\.\d+)/);
          close(LOAD);
     }
     return $load;
}

#Return the list of client for which max_load is => ld
#param : load
sub get_possible_client(#){
    my $ld = shift;
    my @list = ();

    foreach my $arg (keys %{$conf{'client'}}){
        my %hash = %{$conf{'client'}{$arg}};
        if ($hash{'max_load'} >= $ld){
            push(@list,$arg);
        }
    }
    return \@list;
}


#Return the client that should be executed according to priorities
#given in conf file
# Refaire avec calcul du min de launches/prio !
sub get_next(#){
    my $ref = shift;
    my @possible_client = @{$ref};
    #List des proc executes assez souvent
    my $client = '';
    my $min_ratio = -1;

    foreach my $arg (@possible_client) {
        if ($ratio_launch_prio{$arg} < $min_ratio or $min_ratio == -1){
            $min_ratio=$ratio_launch_prio{$arg};
            $client=$arg;
        }
    }

    if ($client) {
        #Update ratio for him
        $launches{$client}++;
        $ratio_launch_prio{$client}=$launches{$client}/$conf{'client'}{$client}{'priority'};
        return $client;
    }else{
        &debug_msg("No client runnable in get_next\n");
        return;
    }
    return;
}

#Elimine les clients présent dans la liste qui sont en cours d'éxécution et
#qui n'ont pas le allow_many (pour pas les éxécuter deux fois)
#Elimine aussi les clients qui ont terminé depuis moins que min_schedule
sub trim_possible_client(#){
    my $ref=shift;
    my @out_list;


    foreach my $arg (@$ref){
        if (${${$conf{'client'}}{$arg}}{'allow_many'} eq "no"){
            #Exec only one
            if ((time - $last_schedule{$arg}) >= ${${$conf{'client'}}{$arg}}{'min_schedule'}){
               push(@out_list,$arg) unless grep($_ eq $arg, values %running);
            }
        }else{
            push(@out_list,$arg);
        }
    }

    return \@out_list;
}


sub change_uid_gid(#){
    my $client = shift;
    if ($conf{'client'}{$client}{'gid'}){
        &debug_msg("Changing gid to $conf{'client'}{$client}{'gid'} for $client ...");
#        $( = $conf{'client'}{$client}{'gid'};
#        $) = $conf{'client'}{$client}{'gid'};
        if (POSIX::setgid($conf{'client'}{$client}{'gid'})){
            &debug_msg("done\n");
        } else {
            &debug_msg("error, $!\n");
            exit(1);
        }
    }
    if ($conf{'client'}{$client}{'uid'}){
        &debug_msg("Changing uid to $conf{'client'}{$client}{'uid'} for $client ...");
#        $< = $conf{'client'}{$client}{'uid'};
#        $> = $conf{'client'}{$client}{'uid'};
        if (POSIX::setuid($conf{'client'}{$client}{'uid'})){
            &debug_msg("done\n");
        } else {
            &debug_msg("error, $!\n");
            exit(1);
        }
    }
}


#Sends mail on the input of the command (pipe)
sub send_data(#) {
    # TODO check that the child has properly finished before moving
    # the file tu cur/
    my $client = shift;
    my $fich = shift;
    &debug_msg("run $conf{'client'}{$client}{'command'} with file $fich for $client\n");
    my $pid = fork;
    if (!defined $pid) {
        die "cannot fork $!";
    } elsif ($pid == 0) {
        # fils
        if (open(STDIN, '<', $fich)) {
            &change_uid_gid($client);
            &debug_msg("sending output to $conf{'client'}{$client}{'command'} with file $fich for $client $fich openned\n");
            exec $conf{'client'}{$client}{'command'} or die "exec error $!";
        } else {
            die "Error opening $fich : $!\n";
        }
    } else {
        # père
        wait;
        &debug_msg("sending output to $conf{'client'}{$client}{'command'} with file $fich for $client done\n");
        # return true if the program exited normaly
        return ($? >> 8) == 0;
    }
}

sub list_files(#) {
    my $client = shift;
    my %hash = %{$conf{'client'}{$client}};
    if ($hash{'mbox'} =~ /\/$/) { #ok, maildir format
        my @tomove;
        my @args;
        my $path = $hash{'mbox'};
        $path =~ s/\/$//igo; # suppress the final /
        &debug_msg("Sending datas for $hash{'mbox'}\n");
        # read the dir
        if (opendir MAILDIR, "$path/new") {
            my $nb_left = $hash{'nb_mails'};
            while (my $fich = readdir MAILDIR) {
                # skip . and ..
                next if ($fich eq "." or $fich eq "..");
                # read the dir until the max number of mail is done
                &debug_msg("nb_left : $nb_left\n");
                last if ($nb_left-- == 0);
                &debug_msg("File : $fich\n");
                # if add_to_cmdline is true, add to the list
                if ($hash{'add_to_cmdline'}) {
                    push @args, $fich;
                } else {
                    # else run the command for each file
                    if (&send_data($client, "$path/new/$fich")) {
                        push @tomove, $fich;
                    }
                }
                &debug_msg("Done file : $fich, $?\n");
            }
            closedir MAILDIR;
        } else {
            print STDERR "Error opening $path/new : $!\n";
        }
        # if add_to_cmdline is true and there are files to treat,
        # run the command
        if ($hash{'add_to_cmdline'} and scalar @args > 0) {
            chdir "$path/new" or die "Cannot chdir to $path/new : $!";
            &debug_msg("run $hash{'command'} with files @args for $client\n");
            my @cmd = split(/ /, $hash{'command'});
            push @cmd, @args;
            &debug_msg("@cmd\n");
            my $pid = fork;
            if (!defined $pid) {
                die "cannot fork $!";
            } elsif ($pid == 0) {
                # fils
                &change_uid_gid($client);
                exec @cmd or die "exec error $!";
            } else {
                # père
                wait;
                my $status = $? >> 8;
                if ($status == 0) {
                    # if the command didn't fail, mark the files to be moved
                    @tomove = @args;
                }
            }
        }
        # if there is files to move, moves them
        foreach my $fich (@tomove) {
            &debug_msg("$path/new/$fich -> $path/cur/$fich ... ");
            if (rename("$path/new/$fich", "$path/cur/$fich")){
                &debug_msg("ok\n");
            } else {
                print STDERR "Error moving $path/new/$fich, keeped : $!\n";
            }
        }
    } else {
        &debug_msg("Mbox format not yet supported.\n");
        exit(1);
    }
}



sub launch(#){
    my $client = shift;
    &change_uid_gid($client);
    #Launch the command of a simple client
    &debug_msg("Son $client, launching $conf{'client'}{$client}{'command'}\n");
    exec($conf{'client'}{$client}{'command'});
}


sub main_loop {

    my $ld;
    my $nchild = 0;

    while (1) {

        if ($reload_conf == 1){
            #We have to load conf again
            $reload_conf=0;
            &debug_msg("Reloading configuration .... \n");
            &debug_msg("  Waiting all child to terminate ...");
            while ((my $kid=wait) != -1){
               $nchild--;
               delete($running{$kid});
            }
            &debug_msg("done\n");
            &debug_msg("  Restarting                     ...");
            &init;
            &init_sched;
            &debug_msg("done\n");
        }


        if ($nchild >= $conf{'max_client'}){
            #We have to wait for one child (Blocking)"
            &debug_msg("Waiting for childs to terminate\n");
            my $kid=wait;
            if ($kid>0){
                &debug_msg("Kid=$kid est mort, c'était un $running{$kid}\n");
                $nchild--;
                delete($running{$kid});
            }
        } else {
            #Rip child terminated
            &debug_msg("Checking dead childs....\n");
            while ( (my $kid = waitpid(-1, WNOHANG)) > 0 ){
                &debug_msg("Kid=$kid est mort, c'était un $running{$kid}\n");
                $nchild--;
                delete($running{$kid});
            }

            #Look for a client to execute
            my $ld = &get_load;
            &debug_msg("Load = $ld, processing\n");
            my $possible_client = &get_possible_client($ld);
            my @list = @{$possible_client};
            &debug_msg("Avant Trim :  \n");
            &debug_msg(Dumper($possible_client));
            $possible_client = &trim_possible_client($possible_client);
            &debug_msg("Après Trim : \n");
            &debug_msg(Dumper($possible_client));
            my $client = &get_next($possible_client);
            if ($client) {
                &debug_msg("$client was chosen, launching\n");
                $last_schedule{$client} = time ;
                my $pid = fork;
                if (!defined $pid) {
                    print STDERR "cannot fork: $!\n";
                } elsif ($pid != 0) {
                    #Pere, on marque qu'on l'a lancé
                    $running{$pid} = $client;
                    $nchild++;
                    &debug_msg("$client launched as PID $pid\n");
                    &debug_msg(Dumper(\%running));
                    &debug_msg(Dumper(\%launches));
                } else {
                    #Fils
                    if ($conf{'client'}{$client}{'mbox'}) {
                        #We have to send data ourselves
                        &list_files($client);
                    } else {
                        #We only have to execute a command
                        &launch($client);
                    }
                    exit(0);
                }
            } else {
                &debug_msg("No client runable\n");
                sleep($conf{'sleep_poll'});
            }
            sleep($conf{'active_poll'});
        }
    }
}



##########
## Main ##
##########

$SIG{HUP}=\&sigHUP_handler;
&init();
&check_conf();
&init_sched();
&main_loop();