#!/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 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) = @_;
    return ($line =~ tr/\{//) - ($line =~ tr/\}//);
}

sub key_add {
    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_block_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_block_pos = $i
                    if !defined($first_block_pos) && $line =~ /^\h*\S.*\{\h*(?:\R)?$/;
            }

            $depth += brace_delta($line);
        }

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

        return;
    }

    my ($start, $end, $indent) = block_find($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 key_del {
    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) = block_find($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 block_find {
    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 "block '$re' is not closed\n";
    }

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

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

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

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

sub block_del {
    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 suspended_rebuild {
    my ($lines, @list) = @_;

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

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

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

sub suspended_list {
    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 suspended_add {
    my ($lines, $domain) = @_;
    return if !defined($domain) || $domain eq '';

    my @current = suspended_list($lines);
    return if grep { $_ eq $domain } @current;
    suspended_rebuild($lines, @current, $domain);
}

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

    suspended_rebuild($lines, grep { $_ ne $domain } suspended_list($lines));
}

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 } suspended_list($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_del {
    my ($lines, $domain) = @_;

    key_del($lines, 'listener\h+HTTP', 'map', "$domain *");
    block_del($lines, 'virtualhost\h+' . quotemeta($domain));
}

sub vhost_set {
    my ($lines, $vhRoot, $domain, @aliases) = @_;

    vhost_del($lines, $domain);
    block_add($lines, "virtualhost $domain");

    my $block_re = 'virtualhost\h+' . quotemeta($domain);
    key_add($lines, $block_re, 'vhRoot',          $vhRoot);
    # key_add($lines, $block_re, 'configFile',      "/usr/local/lsws/conf/vhosts/$domain.conf");
    key_add($lines, $block_re, 'configFile',      '/usr/local/lsws/conf/vhosts/$VH_NAME.conf');
    key_add($lines, $block_re, 'allowSymbolLink', '1');
    key_add($lines, $block_re, 'enableScript',    '1');
    key_add($lines, $block_re, 'restrained',      '1');
    key_add($lines, $block_re, 'setUIDMode',      '2');

    key_add($lines, 'listener\h+HTTP', 'map', "$domain $domain");
    for my $alias (@aliases) {
        key_add($lines, 'listener\h+HTTP', 'map', "$domain $alias");
    }
}

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

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

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

    my %seen;

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

        my ($vhost, $domain) = ($1, $2);

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

        print "$domain\n";
    }
}

sub member_list {
    my ($lines, $template, $type) = @_;

    my ($t_start, $t_end) = block_find($lines, 'vhTemplate\h+' . quotemeta($template));

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

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

    my $depth = 0;
    for my $i ($t_start + 1 .. $t_end - 1) {
        my $line = $lines->[$i];

        if ($depth == 0 && $line =~ /^\h*member\h+([^\s\{]+)/i) {
            my $name = $1;
            if (   $type eq 'all'
                || ($type eq 'down' &&  exists $down{$name})
                || ($type eq 'up'   && !exists $down{$name})) {
                print "$name\n";
            }
        }

        $depth += brace_delta($line);
    }
}

sub member_del {
    my ($lines, $template, $domain) = @_;

    my ($t_start, $t_end) = block_find($lines, 'vhTemplate\h+' . quotemeta($template));

    my $depth = 0;
    for my $i ($t_start + 1 .. $t_end - 1) {
        my $line = $lines->[$i];

        if ($depth == 0 && $line =~ /^\h*member\h+\Q$domain\E\h*(\{)?\h*(?:\R)?$/) {
            my $m_end = $i;

            if (defined $1) {
                my $d = 1;
                for my $j ($i + 1 .. $t_end - 1) {
                    $d += brace_delta($lines->[$j]);
                    if ($d == 0) { $m_end = $j; last; }
                }
                die "member '$domain' block is not closed\n" if $m_end == $i;
            }

            splice @$lines, $i, $m_end - $i + 1;
            return;
        }

        $depth += brace_delta($line);
    }
}

sub member_set {
    my ($lines, $template, $domain, @aliases) = @_;

    member_del($lines, $template, $domain);

    my ($t_start, $t_end, $indent) = block_find($lines, 'vhTemplate\h+' . quotemeta($template));

    my @new;
    if (@aliases) {
        push @new, fmt_line($indent, 'member', "$domain {");
        push @new, fmt_line($indent . '  ', 'vhAliases', join(', ', @aliases));
        push @new, "$indent}\n";
    } else {
        push @new, fmt_line($indent, 'member', $domain);
    }

    splice @$lines, $t_end, 0, @new;
}

sub member_alias {
    my ($lines, $template, $domain) = @_;

    my ($t_start, $t_end) = block_find($lines, 'vhTemplate\h+' . quotemeta($template));

    my $depth = 0;
    for my $i ($t_start + 1 .. $t_end - 1) {
        my $line = $lines->[$i];

        if ($depth == 0 && $line =~ /^\h*member\h+(\S+)\h*\{\h*(?:\R)?$/) {
            my $mname = $1;
            my $match = ($domain eq 'all' || $domain eq $mname);

            if ($match) {
                my $d = 1;
                for my $j ($i + 1 .. $t_end - 1) {
                    if ($d == 1) {
                        my @m = parse_kv_line($lines->[$j], 'vhAliases');
                        if (@m) {
                            for my $a (split /\h*,\h*/, $m[1]) {
                                next if $a eq '';
                                print "$a\n";
                            }
                            last;
                        }
                    }
                    $d += brace_delta($lines->[$j]);
                    last if $d == 0;
                }

                return unless $domain eq 'all';
            }
        }

        $depth += brace_delta($line);
    }
}

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 'key_add') {
    my ($block_re, $key, $value) = @args;
    defined $block_re or die "block_re is required\n";
    defined $key        or die "key is required\n";
    defined $value      or die "value is required\n";
    key_add(\@L, $block_re, $key, $value);
}
elsif ($mode eq 'key_set') {
    my ($block_re, $key, $value) = @args;
    defined $block_re or die "block_re is required\n";
    defined $key        or die "key is required\n";
    defined $value      or die "value is required\n";
    key_del(\@L, $block_re, $key, '');
    key_add(\@L, $block_re, $key, $value);
}
elsif ($mode eq 'key_mask_set') {
    my ($block_re, $key, $mask, $value) = @args;
    defined $block_re or die "block_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";
    key_del(\@L, $block_re, $key, $mask);
    key_add(\@L, $block_re, $key, $value);
}
elsif ($mode eq 'key_del') {
    my ($block_re, $key, $mask) = @args;
    defined $block_re or die "block_re is required\n";
    defined $key        or die "key is required\n";
    $mask //= '';
    key_del(\@L, $block_re, $key, $mask);
}
elsif ($mode eq 'key_mask_del') {
    my ($block_re, $key, $mask) = @args;
    defined $block_re or die "block_re is required\n";
    defined $key        or die "key is required\n";
    defined $mask       or die "mask is required\n";
    key_del(\@L, $block_re, $key, $mask);
}
elsif ($mode eq 'block_add') {
    my ($header) = @args;
    defined $header && length $header or die "block header is required\n";
    block_add(\@L, $header);
}
elsif ($mode eq 'block_del') {
    my ($header_re) = @args;
    defined $header_re && length $header_re or die "block header pattern is required\n";
    block_del(\@L, $header_re);
}
elsif ($mode eq 'suspended_list') {
    print "$_\n" for suspended_list(\@L);
    exit 0;
}
elsif ($mode eq 'suspended_del') {
    my ($domain) = @args;
    defined $domain && length $domain or die "domain is required\n";
    suspended_del(\@L, $domain);
}
elsif ($mode eq 'suspended_add') {
    my ($domain) = @args;
    defined $domain && length $domain or die "domain is required\n";
    suspended_add(\@L, $domain);
}
elsif ($mode eq 'vhost_list') {
    my ($type) = @args;
    vhost_list(\@L, $type // 'all');
    exit 0;
}
elsif ($mode eq 'vhost_del') {
    my ($domain) = @args;
    defined $domain && length $domain or die "domain is required\n";
    vhost_del(\@L, $domain);
}
elsif ($mode eq 'vhost_set') {
    my ($vhRoot, $domain, @aliases) = @args;
    defined $vhRoot     && length $vhRoot     or die "vhRoot is required\n";
    defined $domain     && length $domain     or die "domain is required\n";
    vhost_set(\@L, $vhRoot, $domain, @aliases);
}
elsif ($mode eq 'vhost_alias') {
    my ($name) = @args;
    vhost_alias(\@L, $name);
    exit 0;
}
elsif ($mode eq 'member_list') {
    my ($template, $type) = @args;
    defined $template && length $template or die "template is required\n";
    defined $type && length $type         or die "type is required\n";
    member_list(\@L, $template, $type);
    exit 0;
}
elsif ($mode eq 'member_del') {
    my ($template, $domain) = @args;
    defined $template && length $template or die "template is required\n";
    defined $domain   && length $domain   or die "domain is required\n";
    member_del(\@L, $template, $domain);
}
elsif ($mode eq 'member_set') {
    my ($template, $domain, @aliases) = @args;
    defined $template && length $template or die "template is required\n";
    defined $domain   && length $domain   or die "domain is required\n";
    member_set(\@L, $template, $domain, @aliases);
}
elsif ($mode eq 'member_alias') {
    my ($template, $domain) = @args;
    defined $template && length $template or die "template is required\n";
    defined $domain   && length $domain   or die "domain is required\n";
    member_alias(\@L, $template, $domain);
    exit 0;
}
else {
    die "unknown mode '$mode'\n";
}

$content = join '', @L;
$content =~ s/\n{3,}/\n\n/g;

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

exit 0;