#!/usr/bin/perl -w

# $Id$

=head1 NAME

    lfw - управление перенаправлением портов со стороны сервера

=head1 USAGE

    lfw --help
    lfw --restore
    lfw --clean
    lfw [--debug]
    lfw [--debug] instance
    lfw [--debug] instance +port,-port,...

=head1 SYNOPSIS

    # общее
    # посмотреть на текущий список перенаправлений
    lfw 
    # посмотреть на текущий список перенаправлений ppcdata1
    lfw ppcdata1
    # восстановить редиректы, записанные в файлах состояний (полезно после перезагрузки)
    lfw --restore

    # со стороны mysql-сервера
    # закрыть ppcdata1 на запись
    lfw ppcdata1 -write
    # открыть ppcdata1 на чтение, закрыть мастер
    lfw ppcdata1 +read,-master
    # открыть ppcdata1 _только_ на чтение
    lfw ppcdata1 read

=head1 DESCRIPTION

    Для lfw создаются конфиги, которы записаны в формате YAML, лежат в /etc/lfw.d и содержат
    server_port (который реально слушают на сервере) и некоторое количество названий и номеров портов,
    к которым могут подсоединяться клиенты снаружи и которые редиректятся (или нет) на server_port.

    Состояние текущих редиректов записывается в файлы в директории /var/spool/lfw

==head1 EXAMPLES

конфиг:
/etc/lfw.d/ppcdata1
---
server_port: 3006
ports:
  write: 3306
  read: 3406

состояние:
/var/spool/lfw/ppcdata1
---
comment: automaticaly generated at xxxx-xx-xx
ports:
  - read

=internals

iptables -t nat -I PREROUTING -p tcp ! -s 127.0.0.1 --dport 4406 -j REDIRECT --to-ports 3306

# for client dnat
# iptables -t nat -I OUTPUT -d 1.1.1.1 -p tcp --dport 44XX -j DNAT --to-destination 87.250.243.164:44XX

=cut

use strict;
use warnings;

use File::Slurp;
use YAML qw//;
use Getopt::Long qw/:config no_permute/;
use POSIX qw/strftime/;


my $CONF_DIR = "/etc/lfw.d";
my $STATE_DIR = "/var/spool/lfw";
my $LOG = '/var/log/lfw.log';
my $DEBUG = 0;
my $RESTORE = 0;
my $CLEAN = 0;

open(LOG, ">>", $LOG) || die "Can't open $LOG: $!";
my_log(join(" ", "start:", $0, @ARGV));

GetOptions(
    "debug" => \$DEBUG,
    "help" => \&help,
    "restore" => \$RESTORE,
    "clean" => \$CLEAN,
    ) || usage();

my $ipv6_redir_supported = check_ipv6_redir_support();
my_log("ipv6 supported: " . ($ipv6_redir_supported ? "yes" : "no"));

my $c;
# читаем конфиги
$c->{confs} = read_yaml_dir($CONF_DIR);
$c->{ports2name} = get_ports2name($c);
# читаем записанное состояние
$c->{states} = read_yaml_dir($STATE_DIR);
# получаем информацию о текущих перенаправлениях
$c->{redirs} = read_current_redirs();

# разбираем параметры
if ($RESTORE) {
    usage() if @ARGV;
    restore_state($c);
} elsif ($CLEAN) {
    usage() if @ARGV;
    clean_redirs($c);
} elsif (!@ARGV) {
    show_state($c);
} else {
    my $inst = shift @ARGV;
    if (!exists $c->{confs}{$inst}) {
        usage("Unknown config name: $inst");
    }
    if (@ARGV > 1) {
        usage();
    } elsif (@ARGV == 1) {
        my $new_state = calc_new_state($c, $inst, [split ',', $ARGV[0]]);
        set_redirs($c, $inst, $new_state);
        $c->{redirs} = read_current_redirs();
        $c->{states} = read_yaml_dir($STATE_DIR);
        show_state($c, $inst);
    } else {
        show_state($c, $inst);
    }
}

#### Контроллеры

=head2 show_state
    
    Вывести на экран состояние всех редиректов или редиректов одного конфига

=cut
sub show_state {
    my ($c, $inst) = @_;
    for my $conf_name ($inst ? ($inst) : sort keys %{$c->{confs}}) {
        print "$conf_name\n";
        my $conf = $c->{confs}->{$conf_name};
        my @redirs;
        # описываем текущее состояние
        for my $port_name (sort keys %{$conf->{ports}}) {
            my $port = $conf->{ports}->{$port_name};
            if (my $redir_port = $c->{redirs}->{$port}) {
                push @redirs, "$port_name:$redir_port";
                if ($redir_port == $conf->{server_port}) {
                    print "  $port_name($port) -> $redir_port\n";
                } else {
                    print "  $port_name($port) -> $redir_port - INCORRECT\n";
                }
            } else {
                print "  $port_name($port) -> X\n";
            }
        }
        # смотрим, что должно быть в state
        my $states_str = join ",", sort map {"$_:$conf->{server_port}"} @{$c->{states}->{$conf_name}->{ports} || []};
        my $redirs_str = join ",", sort @redirs;
        if ($states_str ne $redirs_str) {
            print "  INCORRECT state file: '$states_str' vs '$redirs_str'\n";
        }
    }
}

=head2 restore_state

    Установить редиректы, сохранённые в файлах состояний 

=cut
sub restore_state {
    my ($c) = @_;
    for my $inst (sort keys %{$c->{confs}}) {
        my %new_state_hash = map {$_ => 1} @{$c->{states}->{$inst}->{ports}||[]};
        set_redirs($c, $inst, \%new_state_hash);
    }
}

=head2 clean_redirs

    Удалить все редиректы из iptables, файлы состояний не меняются

=cut
sub clean_redirs {
    my ($c) = @_;
    for my $port (sort {$a <=> $b} keys %{$c->{redirs}}) {
        del_one_redir($port, $c->{redirs}->{$port});
    }
}

=head2 set_redirs

    Привести редиректы в соотвествие к переданному состоянию
    new_state - ссылка на хэш, ключи - названия портов, которые должны редиректиться

=cut
sub set_redirs {
    my ($c, $inst, $new_state) = @_;
    my $conf = $c->{confs}->{$inst};
    my $server_port = $conf->{server_port};
    for my $port_name (sort keys %{$conf->{ports}}) {
        my $port = $conf->{ports}->{$port_name};
        my $redir_port = $c->{redirs}->{$port};
        if (exists $new_state->{$port_name}) {
            if ($redir_port && $redir_port == $server_port) {
                # all ok
            } elsif ($redir_port) {
                del_one_redir($port, $redir_port);
                add_one_redir($port, $conf->{server_port});
            } else {
                add_one_redir($port, $conf->{server_port});
            }
        } elsif ($redir_port) {
            del_one_redir($port, $redir_port);
        }
    }
    # пишем данные в файл
    my $status = {
        comment => "Generated automaticaly at ".strftime("%Y-%m-%d %H:%M:%S", localtime),
        ports => [sort keys %$new_state],
    };
    write_file("$STATE_DIR/$inst", {atomic => 1}, YAML::Dump($status));
}

#### вспомогательные функции

# приходит ссылка на массив из правил, возвращаем ссылку на хэш с портами, которые должны быть включены
# ['read', '+write', '-read'] -> {write => 1}
sub calc_new_state {
    my ($c, $inst, $rules) = @_;
    my $conf = $c->{confs}->{$inst};
    # вычисляем новое состояние
    my %new_state_hash = map {$_ => 1} @{$c->{states}->{$inst}->{ports}||[]};
    my $reseted;
    if (!@$rules) {
        %new_state_hash = ();
    } else {
        for my $r (@$rules) {
            my ($op, $port_name) = $r =~ /^(\+|-)?(.*)$/;
            if (!exists $conf->{ports}->{$port_name}) {
                die "Port name $port_name is not exists";
            }
            if (!$op) {
                %new_state_hash = () if !$reseted++;
                $new_state_hash{$port_name} = 1;
            } elsif ($op eq '+') {
                $new_state_hash{$port_name} = 1;
            } else {
                delete $new_state_hash{$port_name};
            }
        }
    }
    return \%new_state_hash;
}

sub add_one_redir {
    my ($port, $redir_port) = @_;
    # записи не в lfw-цепочке будут удалены hbf-ом, но в нем есть общие правила на "все в LFW"
    # пока нас это устраивает, аккуратнее было бы проверять, есть ли hbf-правило, если нет - прописывать его
    my_exec_quiet("iptables --wait -t nat -I PREROUTING -p tcp ! -s 127.0.0.1 --dport $port -j LFW");
    my_exec_quiet("iptables --wait -t nat -I OUTPUT -p tcp --dport $port -j LFW");
    my_qx("iptables --wait -t nat -I LFW -p tcp --dport $port -j REDIRECT --to-ports $redir_port");
    if ($ipv6_redir_supported) {
        my_exec_quiet("ip6tables --wait -t nat -I PREROUTING -p tcp ! -s ::1 --dport $port -j LFW");
        my_exec_quiet("ip6tables --wait -t nat -I OUTPUT -p tcp --dport $port -j LFW");
        my_qx("ip6tables --wait -t nat -I LFW -p tcp --dport $port -j REDIRECT --to-ports $redir_port");
    }
}

sub del_one_redir {
    my ($port, $redir_port) = @_;
    my_exec_quiet("iptables --wait -t nat -D PREROUTING -p tcp ! -s 127.0.0.1 --dport $port -j LFW");
    my_exec_quiet("iptables --wait -t nat -D OUTPUT -p tcp --dport $port -j LFW");
    my_qx("iptables --wait -t nat -D LFW -p tcp --dport $port -j REDIRECT --to-ports $redir_port");
    if ($ipv6_redir_supported) {
        my_exec_quiet("ip6tables --wait -t nat -D PREROUTING -p tcp ! -s ::1 --dport $port -j LFW");
        my_exec_quiet("ip6tables --wait -t nat -D OUTPUT -p tcp --dport $port -j LFW");
        my_qx("ip6tables --wait -t nat -D LFW -p tcp --dport $port -j REDIRECT --to-ports $redir_port");
    }
}

=internals

Chain PREROUTING (policy ACCEPT)
target     prot opt source               destination         
REDIRECT   tcp  -- !localhost            anywhere            tcp dpt:4406 redir ports 3306 
REDIRECT   tcp  -- !127.0.0.1            0.0.0.0/0           tcp dpt:3306 redir ports 3006

Chain POSTROUTING (policy ACCEPT)
target     prot opt source               destination         

Chain OUTPUT (policy ACCEPT)
target     prot opt source               destination         
DNAT       tcp  --  anywhere             localhost           tcp dpt:4406 to:87.250.243.164:4406 

=cut

#ip6tables -t nat -L PREROUTING -n
#Chain PREROUTING (policy ACCEPT)
#target     prot opt source               destination         
#REDIRECT   tcp     !::1                  ::/0                 tcp dpt:3308 redir ports 3318
#
#iptables -t nat -L PREROUTING -n
#Chain PREROUTING (policy ACCEPT)
#target     prot opt source               destination         
#REDIRECT   tcp  -- !127.0.0.1            0.0.0.0/0            tcp dpt:3308 redir ports 3318

sub read_current_redirs {
    my_exec_quiet("/sbin/iptables --wait -t nat -N LFW");
    my $iptables_output .= my_qx("iptables --wait -t nat -L LFW -n");
    if ($ipv6_redir_supported) {
        my_exec_quiet("/sbin/ip6tables --wait -t nat -N LFW");
        $iptables_output .= my_qx("ip6tables --wait -t nat -L LFW -n");
    }

    my @rules = grep {!/^(Chain|target)/ && !/^\s*$/} split /\n/, $iptables_output;
    my %redirs;
    my %redirs_cnt;
    for my $rule (@rules) {
        if ($rule =~ /^REDIRECT \s+ tcp [\s-]+ (?:anywhere|0\.0\.0\.0\/0|::\/0) \s+ (?:anywhere|0\.0\.0\.0\/0|::\/0) \s+ tcp \s+
                        dpt:(\d+) \s+ redir \s+ ports \s+ (\d+) \s* $/x
        ) {
            my ($from_port, $to_port) = ($1, $2);
            $redirs{$from_port} = $to_port;
            $redirs_cnt{$from_port}++;
        } else {
            warn "Unknown format of iptables rule: $rule\n";
        }
    }
    for (values %redirs_cnt) {
      next unless ($ipv6_redir_supported && $_ < 2);
      warn "Something goes wrong. Some of ipv4 or ipv6 ports not redirected properly. Fix manually\n";
    }
    return \%redirs;
}

sub read_yaml_dir {
    my $dir = shift;
    opendir(my $dh, $dir) || die "Can't opendir $dir: $!";
    my %data;
    for my $name (grep {!/\./} readdir($dh)) {
        $data{$name} = YAML::Load(scalar read_file("$dir/$name"));
    }
    closedir($dh) || die "Can't closedir $dir: $!";
    return \%data;
}

# получить по конфигам хэш: номер порта - название порта
# 3306 -> ppcdata1.master
sub get_ports2name {
    my ($c) = @_;
    my $ports = {};
    for my $inst (sort keys %{$c->{confs}}) {
        my $conf = $c->{confs}->{$inst};
        _set_port_name($ports, $conf->{server_port}, "$inst");
        for my $port_name (sort keys %{$conf->{ports}}) {
            _set_port_name($ports, $conf->{ports}->{$port_name}, "$inst.$port_name");
        }
    }
    return $ports;
}

sub check_ipv6_redir_support {
    my $iptables_ver_t = qx(iptables -V);
    ($iptables_ver_t) = ($iptables_ver_t =~ /v([\d.]+)/);
    my @iptables_ver = split /\./, $iptables_ver_t;

    my $kernel_ver_t = qx(uname -r);
    ($kernel_ver_t) = ($kernel_ver_t =~ /([\d.]+)/);
    my @kernel_ver = split /\./, $kernel_ver_t;

    for (qw(3 18)) {
        my $v = shift @kernel_ver;
        next if $v == $_;
        $v < $_ ? return 0 : last;
    }
    for (qw(1 4 21)) {
        my $v = shift @iptables_ver;
        next if $v == $_;
        $v < $_ ? return 0 : last;
    }

    return 1;
}

# проверка порта, запись в хэш
sub _set_port_name {
    my ($ports, $port, $name) = @_;
    if (!defined $port) {
        warn "Port $name is not defined";
    } elsif ($port !~ /^\d+$/) {
        warn "Incorrect port $name: '$port'";
    } elsif (exists $ports->{$port}) {
        warn "Ports conflict detected for port $port: $ports->{$port} <-> $name";
    } else {
        $ports->{$port} = $name;
    }
}

sub my_qx {
    my $cmd = shift;
    my $retry_count = 0;
    while ($retry_count++ < 3) {
        my_log($cmd);
        my @out = wantarray ? `$cmd` : scalar(`$cmd`);
        my_log("Result $?:\n".join("", @out));
        if ($? == 0)  {
            return wantarray ? @out : $out[0];
        }
        sleep 1;
    }
    die "Can't execute $cmd: $!";
}


sub my_exec_quiet {
    my $cmd = shift;
    system($cmd . ' 2>/dev/null');
    return;
}

sub my_log {
    my $str = shift;
    my $log_str = sprintf "%s [%d] %s\n", strftime("%Y-%m-%d %H:%M:%S", localtime), $$, $str;
    printf LOG $log_str;
    print STDERR $log_str if $DEBUG;
}

sub usage {
    print STDERR "Error: $_[0]\n" if @_;
    system("podselect -section USAGE $0 | pod2text-utf8 >&2");
    exit(1);
}

sub help {
    system("podselect -section NAME -section SYNOPSIS -section DESCRIPTION $0 | pod2text-utf8");
    exit(0);
}

