#!/usr/bin/env perl
use strict;
use warnings;

my ($file, $mode, @args) = @ARGV;

defined $file && length $file or die "usage: $0 <file> <mode> ...\n";
defined $mode && length $mode or die "mode is required\n";

sub mask_to_re {
    my ($mask) = @_;
    return undef if !defined($mask) || $mask eq '';
    $mask = quotemeta($mask);
    $mask =~ s/\\\*/.*/g;
    return qr/\A$mask\z/;
}

sub parse_kv_line {
    my ($line, $wanted_key) = @_;
    return unless $line =~ /^(\h*)\Q$wanted_key\E(?:\h+(.*?))?\h*(?:\R)?$/;
    my $indent = $1;
    my $value  = defined($2) ? $2 : '';
    return ($indent, $value);
}

sub line_matches_delete {
    my ($line, $wanted_key, $value_re) = @_;
    my @m = parse_kv_line($line, $wanted_key) or return 0;
    return 1 unless $value_re;
    return $m[1] =~ $value_re;
}

sub line_matches_exact {
    my ($line, $wanted_key, $wanted_value) = @_;
    my @m = parse_kv_line($line, $wanted_key) or return 0;
    return $m[1] eq $wanted_value;
}

sub fmt_line {
    my ($indent, $k, $v) = @_;
    return sprintf("%s%-23s %s\n", $indent, $k, $v);
}

sub brace_delta {
    my ($line) = @_;
    my $o = () = $line =~ /\{/g;
    my $c = () = $line =~ /\}/g;
    return $o - $c;
}

sub find_section {
    my ($lines, $re) = @_;

    for (my $i = 0; $i <= $#$lines; $i++) {
        next unless $lines->[$i] =~ /^(\h*)$re\h*\{\h*(?:\R)?$/;

        my $indent = $1 . '  ';
        my $depth  = 1;

        for (my $j = $i + 1; $j <= $#$lines; $j++) {
            $depth += brace_delta($lines->[$j]);
            if ($depth == 0) {
                return ($i, $j, $indent);
            }
        }

        die "section '$re' is not closed\n";
    }

    die "section '$re' not found\n";
}

sub delete_key {
    my ($lines, $section_re, $key, $mask) = @_;
    my $value_re = mask_to_re($mask);

    if ($section_re eq '') {
        my @out;
        my $depth = 0;

        for my $line (@$lines) {
            my $remove = ($depth == 0 && line_matches_delete($line, $key, $value_re)) ? 1 : 0;
            push @out, $line unless $remove;
            $depth += brace_delta($line);
        }

        @$lines = @out;
        return;
    }

    my ($start, $end, undef) = find_section($lines, $section_re);

    my @out;
    push @out, @$lines[0 .. $start];

    my $depth = 1;
    for my $i ($start + 1 .. $end - 1) {
        my $line = $lines->[$i];
        my $remove = ($depth == 1 && line_matches_delete($line, $key, $value_re)) ? 1 : 0;
        push @out, $line unless $remove;
        $depth += brace_delta($line);
    }

    push @out, @$lines[$end .. $#$lines];
    @$lines = @out;
}

sub add_key {
    my ($lines, $section_re, $key, $value) = @_;
    die "value is required for add\n" if !defined($value) || $value eq '';

    if ($section_re eq '') {
        my $depth = 0;

        for my $line (@$lines) {
            if ($depth == 0 && line_matches_exact($line, $key, $value)) {
                return;
            }
            $depth += brace_delta($line);
        }

        my $new = fmt_line('', $key, $value);

        my $root_pos;
        my $first_section_pos;
        $depth = 0;

        for (my $i = 0; $i <= $#$lines; $i++) {
            my $line = $lines->[$i];

            if ($depth == 0) {
                $root_pos = $i
                    if !defined($root_pos) && $line =~ /^\h*serverName\h+\S*/;

                $first_section_pos = $i
                    if !defined($first_section_pos) && $line =~ /^\h*\S.*\{\h*(?:\R)?$/;
            }

            $depth += brace_delta($line);
        }

        if (defined $root_pos) {
            splice @$lines, $root_pos + 1, 0, $new;
        } elsif (defined $first_section_pos) {
            splice @$lines, $first_section_pos, 0, $new;
        } else {
            push @$lines, $new;
        }

        return;
    }

    my ($start, $end, $indent) = find_section($lines, $section_re);

    my $depth = 1;
    for my $i ($start + 1 .. $end - 1) {
        my $line = $lines->[$i];
        if ($depth == 1 && line_matches_exact($line, $key, $value)) {
            return;
        }
        $depth += brace_delta($line);
    }

    my $new = fmt_line($indent, $key, $value);
    splice @$lines, $end, 0, $new;
}

sub build_vhost_section {
    my ($domain) = @_;
    return if !defined($domain) || $domain eq '';

    my @out;
    push @out, "virtualhost $domain {\n";
    push @out, fmt_line('    ', 'vhRoot',          "/var/www/vhosts/$domain");
    push @out, fmt_line('    ', 'configFile',      "/usr/local/lsws/conf/vhosts/$domain.conf");
    push @out, fmt_line('    ', 'allowSymbolLink', '1');
    push @out, fmt_line('    ', 'enableScript',    '1');
    push @out, fmt_line('    ', 'restrained',      '1');
    push @out, fmt_line('    ', 'setUIDMode',      '2');
    push @out, "}\n";

    return join('', @out);
}

sub has_vhost_section {
    my ($lines, $name) = @_;

    for my $line (@$lines) {
        return 1 if $line =~ /^\h*virtualhost\h+\Q$name\E\h*\{/;
    }

    return 0;
}

sub add_vhost_section {
    my ($lines, $name) = @_;

    return if !defined($name) || $name eq '';
    return if has_vhost_section($lines, $name);

    my @section = split /(?<=\n)/, build_vhost_section($name), -1;
    pop @section if @section && $section[-1] eq '';

    if (@$lines && $lines->[-1] !~ /\n\z/) {
        $lines->[-1] .= "\n";
    }

    push @$lines, "\n" if @$lines && $lines->[-1] !~ /^\s*$/;
    push @$lines, @section;
}

sub delete_named_section {
    my ($lines, $header_re) = @_;

    my @out;
    my $deleted = 0;

    for (my $i = 0; $i <= $#$lines; $i++) {
        my $line = $lines->[$i];

        if ($line =~ /^\h*$header_re\h*\{\h*(?:\R)?$/) {
            my $depth = 1;
            $deleted = 1;

            for ($i = $i + 1; $i <= $#$lines; $i++) {
                $depth += brace_delta($lines->[$i]);
                last if $depth == 0;
            }

            next;
        }

        push @out, $line;
    }

    @$lines = @out;
    return $deleted;
}

sub get_suspended_vhosts {
    my ($lines) = @_;

    my $depth = 0;
    for my $line (@$lines) {
        if ($depth == 0) {
            my @m = parse_kv_line($line, 'suspendedVhosts');
            if (@m) {
                return grep { length }
                       map  { s/^\h+|\h+$//gr }
                       split /,/, $m[1];
            }
        }
        $depth += brace_delta($line);
    }

    return;
}

sub set_suspended_vhosts {
    my ($lines, @list) = @_;

    @list = grep { defined($_) && $_ ne '' } @list;

    delete_key($lines, '', 'suspendedVhosts', '');

    if (@list) {
        add_key($lines, '', 'suspendedVhosts', join(',', @list));
    }
}

sub suspend_vhost {
    my ($lines, $domain) = @_;
    return if !defined($domain) || $domain eq '';

    my @current = get_suspended_vhosts($lines);

    my @new = ($domain);
    for my $item (@current) {
        push @new, $item if $item ne $domain;
    }

    set_suspended_vhosts($lines, @new);
}

sub unsuspend_vhost {
    my ($lines, $domain) = @_;
    return if !defined($domain) || $domain eq '';

    my @current = get_suspended_vhosts($lines);
    my @new = grep { $_ ne $domain } @current;

    set_suspended_vhosts($lines, @new);
}

sub get_listener_http_maps {
    my ($lines) = @_;

    my ($start, $end, undef) = find_section($lines, 'listener\h+HTTP');

    my @maps;

    for my $i ($start + 1 .. $end - 1) {
        my $clean = $lines->[$i];
        $clean =~ s/#.*$//;
        $clean =~ s/^\s+|\s+$//g;
        next if $clean eq '';

        if ($clean =~ /^map\s+(\S+)\s+(\S+)$/i) {
            push @maps, [$1, $2];
        }
    }

    return @maps;
}

sub vhost_list {
    my ($lines, $type) = @_;
    $type //= 'all';

    die "unknown vhost list type '$type'\n"
        if $type !~ /\A(?:all|up|down)\z/;

    my @all;
    my %down = map { $_ => 1 } get_suspended_vhosts($lines);

    for my $line (@$lines) {
        my $clean = $line;
        $clean =~ s/#.*$//;
        $clean =~ s/^\s+|\s+$//g;
        next if $clean eq '';

        if ($clean =~ /^virtualhost\s+([^\s\{]+)\s*\{?/i) {
            push @all, $1;
        }
    }

    if ($type eq 'all') {
        print "$_\n" for @all;
    } elsif ($type eq 'down') {
        print "$_\n" for grep { exists $down{$_} } @all;
    } elsif ($type eq 'up') {
        print "$_\n" for grep { !exists $down{$_} } @all;
    }
}

sub vhost_list_map {
    my ($lines, $type) = @_;
    $type //= 'all';

    die "unknown vhost map list type '$type'\n"
        if $type !~ /\A(?:all|up|down)\z/;

    my %down = map { $_ => 1 } get_suspended_vhosts($lines);
    my %seen;

    for my $map (get_listener_http_maps($lines)) {
        my ($vhost, $domain) = @$map;

        next if $vhost ne $domain;
        next if $seen{$vhost}++;

        if ($type eq 'down') {
            next if !exists $down{$vhost};
        } elsif ($type eq 'up') {
            next if exists $down{$vhost};
        }

        print "$vhost\n";
    }
}

sub alias_list {
    my ($lines) = @_;

    my %seen;

    for my $map (get_listener_http_maps($lines)) {
        my ($vhost, $domain) = @$map;

        next if $vhost eq $domain;
        next if $seen{$domain}++;

        print "$domain\n";
    }
}

sub vhost_alias {
    my ($lines, $name) = @_;

    die "virtual host name is required\n"
        if !defined($name) || $name eq '';

    my %seen;

    for my $map (get_listener_http_maps($lines)) {
        my ($vhost, $domain) = @$map;

        next if $vhost ne $name;
        next if $domain eq $name;
        next if $seen{$domain}++;

        print "$domain\n";
    }
}

open my $fh, '<', $file or die "cannot read '$file': $!\n";
local $/;
my $content = <$fh>;
close $fh;

my @L = split /(?<=\n)/, $content, -1;

if ($mode eq 'del') {
    my ($section_re, $key, $mask) = @args;
    defined $section_re or die "section_re is required\n";
    defined $key        or die "key is required\n";
    $mask //= '';
    delete_key(\@L, $section_re, $key, $mask);
}
elsif ($mode eq 'add') {
    my ($section_re, $key, $value) = @args;
    defined $section_re or die "section_re is required\n";
    defined $key        or die "key is required\n";
    defined $value      or die "value is required\n";
    add_key(\@L, $section_re, $key, $value);
}
elsif ($mode eq 'set') {
    my ($section_re, $key, $value) = @args;
    defined $section_re or die "section_re is required\n";
    defined $key        or die "key is required\n";
    defined $value      or die "value is required\n";
    delete_key(\@L, $section_re, $key, '');
    add_key(\@L, $section_re, $key, $value);
}
elsif ($mode eq 'set_masked') {
    my ($section_re, $key, $mask, $value) = @args;
    defined $section_re or die "section_re is required\n";
    defined $key        or die "key is required\n";
    defined $mask       or die "mask is required\n";
    defined $value      or die "value is required\n";
    delete_key(\@L, $section_re, $key, $mask);
    add_key(\@L, $section_re, $key, $value);
}
elsif ($mode eq 'del_masked') {
    my ($section_re, $key, $mask) = @args;
    defined $section_re or die "section_re is required\n";
    defined $key        or die "key is required\n";
    defined $mask       or die "mask is required\n";
    delete_key(\@L, $section_re, $key, $mask);
}
elsif ($mode eq 'vhost_add') {
    my ($name) = @args;
    defined $name && length $name or die "virtual host name is required\n";
    add_vhost_section(\@L, $name);
}
elsif ($mode eq 'vhost_del') {
    my ($name) = @args;
    defined $name && length $name or die "virtual host name is required\n";
    my $quoted = quotemeta($name);
    delete_named_section(\@L, "virtualhost\\h+$quoted");
}
elsif ($mode eq 'vhost_down') {
    my ($name) = @args;
    defined $name && length $name or die "virtual host name is required\n";
    suspend_vhost(\@L, $name);
}
elsif ($mode eq 'vhost_up') {
    my ($name) = @args;
    defined $name && length $name or die "virtual host name is required\n";
    unsuspend_vhost(\@L, $name);
}
elsif ($mode eq 'vhost_list') {
    my ($type) = @args;
    vhost_list(\@L, $type // 'all');
    exit 0;
}
elsif ($mode eq 'vhost_list_map') {
    my ($type) = @args;
    vhost_list_map(\@L, $type // 'all');
    exit 0;
}
elsif ($mode eq 'alias_list') {
    alias_list(\@L);
    exit 0;
}
elsif ($mode eq 'vhost_alias') {
    my ($name) = @args;
    vhost_alias(\@L, $name);
    exit 0;
}
else {
    die "unknown mode '$mode'\n";
}

$content = join '', @L;

open my $out, '>', $file or die "cannot write '$file': $!\n";
print {$out} $content;
close $out or die "cannot close '$file': $!\n";

exit 0;