use feature ':5.10';

BEGIN {
 push @INC, 'src/config' if -e 'src/config/Teeworlds';
 push @INC, "$ENV{'HOME'}/.teeworlds";
}

use POSIX;
use File::Copy;

# TODO: revise $RCON_CID approach. Is it possible to get rid of it? See call to
# start_vote in start_cmd_vote for uglyness
$RCON_CID = -1;
$g_root   = ~0;
$g_all    = ~0;

foreach (keys %config) {
 eval "
  sub $_ {
   if (\@_ > 0) {
    \$config{$_}->set(join(' ', \@_));
   } else {
    return \$config{$_}->get();
   };
  };
 ";
};

sub find(&@) {
 local $_;
 my $test = shift;
 foreach (@_) {
  return $_ if $test->($_);
 };
 return undef;
};

sub position(&@) {
 local $_;
 my $test = shift;
 for (my $i = 0; $i < @_; ++$i) {
  $_ = $_[$i];
  return $i if $test->($_);
 };
 return undef;
};

sub reduce(&@) {
 my $f = shift;
 local $a = shift;
 while (@_ > 0) {
  local $b = shift;
  $a = $f->();
 };
 return $a;
};

sub max {
 return reduce { $a > $b ? $a : $b } @_;
};

sub min {
 return reduce { $a < $b ? $a : $b } @_;
};

sub ensure_directory_exist {
 mkdir $_[0] unless -d $_[0];
};

sub hard_copy {
 my $from = $_[0];
 while (-l $from) {
  $from =~ /^(.*)\//;
  $from = readlink $from;
  die "Cannot copy $_[0]: $!\n" unless defined $from;
  $from = "$1/$from" unless $from =~ /^\//;
 };
 copy $from, $_[1];
};

sub init {
 my $root = $_[0];
 ensure_directory_exist "$root/etc";
 hard_copy '/etc/resolv.conf', "$root/etc/resolv.conf";
 ensure_directory_exist "$root/lib";
 hard_copy "/lib/$_", "$root/lib/$_" 
   foreach ('libnss_dns.so.2', 'libnss_files.so.2', 'libresolv.so.2');
 chroot $root or die "Cannot chroot to $root: $!\n";
 chdir '/' or die "Cannot chdir to /: $!\n";
 setgid $_[1] or die "Cannot change group identity to $_[1]: $!\n";
 setuid $_[2] or die "Cannot set user id to $_[2]: $!\n";
};

sub reply {
 my $s = $_[0];
 my $_;
 $s =~ s/\t/        /g;
 say_rcon $RCON_CID, $_ foreach split "\n", $s;
};

sub quoted_string {
 return qr/\Q$_[0]\E(?:(?>\\[\\\Q$_[0]\E])|.)*?\Q$_[0]\E/;
}

# called by the server
sub execute_line {
 $RCON_CID = $_[0];
 my $cmd = $_[1];

 if ($interactive[$RCON_CID][0]) {
  $interactive[$RCON_CID][0]->($cmd);
  $RCON_CID = -1;
  return;
 };

 my $gid = client_gid($RCON_CID);
 my @result;

 reply "rcon> $cmd";

 if ($gid != $g_root) {
  $cmd =~ s/^ *(\w+) *//;
  my $command = $commands{$1};
  if (!$command) {
   reply 'No such command';
   goto end;
  };

  if (!($gid & $command->{'gid'})) {
   reply 'You have no permissions to execute this command';
   goto end;
  };

  eval { @result = $command->{'sub'}->($cmd) };
 } else {
  @result = eval $cmd;
 };

 if ($@) { reply $@ }
 elsif (@result > 1 || $result[0] ne '') {
  reply $_ foreach @result;
 };

end:
 $RCON_CID = -1;
};

sub _player_cid {
 my $id = $_[0];
 
 if (ref $id eq 'Regexp') {
  my @matches;
  for (my $i = 0; $i < $MAX_CLIENTS; ++$i) {
   next unless client_active($i);
   my $name = client_name($i);
   push @matches, [ $name, $i ] if $name =~ $id;
  };
  return $matches[0][1] if @matches == 1;
  return undef if @matches == 0;
  die "Several player names match $id:\n", map { "$_->[1]\t$_->[0]\n" } @matches;
 };

 return $id if $id =~ /^\d+$/ 
               && $id >= 0 && $id < $MAX_CLIENTS 
               && client_active($id);

 for (my $i = 0; $i < $MAX_CLIENTS; ++$i) {
  return $i if client_active($i) && $id eq client_name($i);
 };

 return undef;
};

$player_cid = \&_player_cid; # dynamic overloaded while executing vote command
sub player_cid { $player_cid->(@_) };

BEGIN {
 my %units = (
  's' => 1,
  'm' => 60,
  'h' => 60*60,
  'd' => 24*60*60,
  'w' => 7*24*60*60,
  'M' => 30*24*60*60,
  'y' => 365*24*60*60,
  'i' => ~0
 );

 sub to_seconds {
  my $result = 0;
                     # float possibly followed by a time unit
  while ($_[0] =~ / *(\d+(?:\.\d*)?(?:[Ee][+-]\d+)?)([^\d ])?/g) {
   if (defined $2) {
    my $unit = $units{$2};
    die "Unknown unit of time: $2\n" unless defined $unit;
    $result += $1 * $unit;
   } else { $result += $1 };
  };
  return $result;
 };

 sub from_seconds {
  my $time = $_[0];
  return $time / $units{$_[1]} if defined $_[1];
  my $result;
  foreach ('d', 'h', 'm', 's') {
   if ($_[0] > $units{$_}) {
    my $t = int $time / $units{$_};
    if ($t != 0) {
     $result .= ', ' if defined $result;
     $result .= $t . $_;
    };
    $time %= $units{$_};
   };
  };
  return $result;
 };
};

sub ip {
 return undef unless $_[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
 return $1 | $2 << 8 | $3 << 16 | $4 << 24;
};

sub sprint_ip {
 return sprintf "%d.%d.%d.%d", map { ($_[0] >> $_) & 0xff } (0, 8, 16, 24);
};

sub sprint_group {
 my $gid = $_[0];
 return '' if $gid == 0;
 return 'root' if $gid == $g_root;
 return join ' ', grep {
  $groups{$_}{'gid'} != $g_root && $groups{$_}{'gid'} & $gid 
 } keys %groups;
}

sub status {
 for (my $i = 0; $i < $MAX_CLIENTS; ++$i) {
  next unless client_active($i);
  reply sprintf "%d\t%s\t%s\t%s", 
                $i, 
                client_name($i), 
                sprint_ip(client_addr($i)), 
                sprint_group(client_gid($i))
 };
};

sub kick {
 my $cid = player_cid($_[0]);
 server_kick($cid, $_[1] || 'kicked by console') if defined $cid;
};

sub ban {
 my $time = to_seconds($_[1]);
 my $ip = ip $_[0];
 if ($ip) {
  server_ban_ip($ip, $time);
 } else {
  my $cid = player_cid($_[0]);
  server_ban($cid, $time) if defined $cid;
 };
};

sub unban {
 my $ip = ip $_[0];
 die "Bad IP address: $_[0]\n" unless defined $ip;
 server_unban($ip);
};

sub bans {
 my $n = server_ban_num();
 for (my $i = 0; $i < $n; ++$i) {
  my ($addr, $expires) = server_ban_get($i);
  reply sprintf "%d\t%s\t%s", 
                $i, 
                sprint_ip($addr), 
                $expires == 0xffffffff 
                ? 'for life' 
                : from_seconds($expires - time);
 };
};

sub su {
 my $password = $_[0];

 if ($password eq '') {
  reply 'Wrong password';
  return;
 };

 my $cid = $RCON_CID;
 my $gid = client_gid($cid);

 my $group = find { $groups{$_}{'password'} eq $password } keys %groups;
 if (!$group) {
  reply 'Wrong password';
  return;
 };

 if ($gid == 0) {
  if (defined &on_client_auth) {
   on_client_auth($cid, $group);
  } else {
   reply sprintf 'Welcome, %s. You have logged in with %s rights',
                 client_name($cid), $group;
  };
 } elsif (($groups{$group}{'gid'} & $gid) == $gid && $groups{$group}{'gid'} != $g_root) {
  reply "You already have $group rights";
 } else {
  reply "You have been granted $group rights";
 };
 server_auth $cid, 
             $gid == $g_root 
             ? $groups{$group}{'gid'} 
             : $gid | $groups{$group}{'gid'};
};

# called by the server
sub auth {
 $RCON_CID = $_[0];
 su $_[1];
 $RCON_CID = -1;
};

sub start_vote {
 my $cid = @_ > 2 ? shift : $RCON_CID;
 my ($description, $action) = @_;
 server_start_vote 
   $cid,
   sprintf(
    '%s is voting for %s', 
    $cid == -1 ? 'server' : client_name($cid), 
    $description
   ),
   $description,
   sub {
    local $player_cid = sub {
     my $cid = _player_cid(@_);
     return $cid if defined($cid) && !$vote_client_disconnected[$cid];
     return undef;
    };
    $action->();
    undef @vote_client_disconnected;
   };
}

sub start_cmd_vote {
 my $cid = @_ > 1 ? shift : $RCON_CID;
 my $cmd = $_[0];
 my $gid = client_gid($cid);
 
 my $arg = $cmd;
 $arg =~ s/^ *(\w+) *//;
 my $command = $commands{$1};
 if (!$command) {
  die "No such command\n";
  return;
 };

 my $vgid = $command->{'vgid'};
 unless ($gid & $vgid || defined($vgid) && $vgid == 0) {
  die "You have no permissions to vote for this command\n";
  return;
 };

 my $description;
 $description = $command->{'vcheck'}->($cid, $gid, $arg) 
   if $command->{'vcheck'};
 start_vote $cid, 
            $description ? $description : $cmd,
            sub { local $RCON_CID = $cid; $command->{'sub'}->($arg, 1) };
};

# called by the server when client calls a predefined vote
sub client_start_vote {
 eval { start_cmd_vote @_ };
 if ($@) {
  $@ =~ s/\t/        /g;
  chat $cid, $_ foreach split "\n", $@;
 };
}

sub vote {
 if ($_[0] eq 'yes' || $_[0] == 1) {
  vote_enforce(1);
 } elsif ($_[0] eq 'no' || $_[1] == 0) {
  vote_enforce(0);
 } else {
  die 'vote: yes or no expected';
 }
};

sub on_event {
 my $event = shift;
 # I wish Perl has Lisp :after method qualifier...
 $_->(@_) foreach values %{$hooks{$event}}
};

$hooks{'leave'}{'teeworlds'} = sub {
 my $cid = $_[0];
 $vote_client_disconnected[$cid] = 1 if vote_active();
 undef $interactive[$cid];
};

sub call_interactive(&;@) {
 my $f = shift;
 my $F = sub {
  local $quit;
  $quit = sub { undef $quit; shift @{$interactive[$RCON_CID]} };
  eval { $f->(@_) };
  if ($@) {
   reply $@;
   $quit->() if $quit;
  };
 };
 unshift @{$interactive[$RCON_CID]}, $F;
 $F->(@_) if @_;
 return $F;
};

sub splitn {
 my ($string, $n) = @_;
 my $fuzz = $_[2] // int $n / 5;
 for (substr $string, $n-$fuzz, $fuzz) {
  $n = $n-$fuzz + $+[0] if /.*[^\w\s\d](?:\s+|$)/ || /.*\s/;
 }
 return (substr($string, 0, $n), substr($string, $n));
};

sub split_long_string {
 my ($string, $limit) = @_;
 my $l = length $string;
 return $string if $l < $limit;
 my $fuzz = $_[2] // int $limit / 5;

 my @result;
 my $i = 0;
 while ($i + $limit < $l) {
  my ($s, $rest) = splitn($string, $limit, $fuzz);
  push @result, $s;
  $string = $rest;
  $i += length $s;
 };
 push @result, $string if $string !~ /^\s*$/;

 return @result;
};

# TODO: test these for different resolutions... or collect users' complains
$more_cols = 165; 
$more_rows = 23;

sub more {
 my @strings = grep {
  ! /^\s*$/
 } map {
  split_long_string $_, $more_cols
 } map { 
  split "\n" 
 } @_;
 my $current = 0;
 my $regexp = qr/./;
 my $forward = 1;
 my $print = sub {
  if ($_[1])     { $current += $_[0] } 
  elsif (@_ > 0) { $current  = $_[0] };
  my $line = $current;
  reply $strings[$current++] 
    while $current < @strings && $current < $line + $more_rows;
  if ($current >= @strings) { $quit->() }
  else {
   ++$line;
   reply "more, line $line. Send \"h\" for help"
     unless $done;
  };
 };
 call_interactive {
  given($_[0]) {
   when ('q') { 
    reply 'more: quit';
    $quit->();
   };
   when ('b') { $print->(-2 * $more_rows, 1) };
   when ('.') { $print->(-$more_rows, 1) };
   when (/g *(\d+)?/) { $print->(min(max(($1 // 1) - 1, 0), scalar @strings)) };
   when ([ qr/^\/(.*)/, sub { $forward ? $_[0] eq 'n' : $_[0] eq 'N' }]) {
    if (defined $1) {
     $regexp = qr/$1/ unless $1 eq '';
     $forward = 1;
    };
    for (my $i = max($current - $more_rows, 0) + 1; $i < @strings; ++$i) {
     if ($strings[$i] =~ $regexp) {
      $print->($i);
      return;
     };
    };
    reply 'Pattern not found';
   };
   when ([ qr/^\?(.*)/, sub { $forward ? $_[0] eq 'N' : $_[0] eq 'n' }]) {
    if (defined $1) {
     $regexp = qr/$1/ unless $1 eq '';
     $forward = undef;
    };
    for (my $i = $current-$more_rows-1; $i > 0; --$i) {
     if ($strings[$i] =~ $regexp) {
      $print->($i);
      return;
     };
    };
    reply 'Pattern not found';
   };
   when ('h') {
    more('Available commands:', 
         'b: back one screen', 
         '.: redisplay the current screen',
         '/regexp: search for a pattern',
         '?regexp: search for a pattern in the backwards direction',
         'n: repeat last search',
         'N: repeat last search in the other direction',
         'g number: go to a given line',
         'q: quit',
         'everything else: next screen');
    return;
   }
   default { $print->() };
  };
 } undef;
 return undef;
};

sub help_command_list {
 my $test = shift;
 map {
  my $help = $commands{$_}{'help'};
  if (defined $help) {
   sprintf '%s: %s%s',
           $_,
           lc(substr $commands{$_}{'help'}, 0, 1),
           substr($commands{$_}{'help'}, 1);
  } else { $_ }
 } sort {
  $a cmp $b
 } grep $test->($_), keys %commands;
};

sub help {
 my $gid = client_gid($RCON_CID);

 if ($_[0] ne '') {
  my $cmd = $commands{$_[0]};
  die "No such command\n" if !$cmd;
  die "Why bother? You have no permissions to execute it anyway\n"
    unless $gid & ($cmd->{'gid'} | $cmd->{'vgid'});
  reply $cmd->{'help'};
  return;
 };

 my @executable = help_command_list sub { $gid & $commands{$_[0]}{'gid'}  };
 my @votable    = help_command_list sub { $gid & $commands{$_[0]}{'vgid'} };
 my @list;
 @list = ('-- Executable commands:', @executable)  if @executable;
 @list = (@list, '-- Votable commands:', @votable) if @votable;

 more @list;
};

sub chat {
 my $cid = @_ > 2 ? shift : -1;
 my $target = @_ > 1 ? shift : 'all';
 my $text = $_[0];

 $cid = player_cid $cid unless $cid == -1;

 given ($target) {
  when ('blue') { $target = -1 };
  when ('red')  { $target = -2 };
  when ('spec') { $target = -3 };
  when ('all')  { $target = -4 };
  default {
   $target = player_cid($target);
   return unless defined $target;
  };
 };

 send_chat($cid, $target, $text);
};

sub broadcast {
 my $cid = @_ > 1 ? player_cid(shift) : -1;
 my $text = $_[0];

 send_broadcast($cid, $text);
};

# called by the server when someone produce chat message
# Parameters:
# $_[0]: client id (-1 for the server itself)
# $_[1]: chat target
# $_[2]: chat message
# $_[3]: binded message
sub server_send_chat {
 send_chat @_[0..2] unless $_[0] >= 0 && $_[3];
};

sub team {
 my $cid = player_cid $_[0];
 die "No such player\n" unless defined $cid;
 my $team = $_[1];
 given ($team) {
  when ('blue') { $team = 1  };
  when ('red')  { $team = 0  };
  when ('spec') { $team = -1 };
  when (-1, 0, 1) {};
  default {
   die "Wrong team: $team\n";
  };
 };
 set_team($cid, $team);
};

sub sv_playerlimit {
 if (@_ > 0) {
  sv_spectator_slots($_[0] >= 0 ? $MAX_CLIENTS - $_[0] : 0);
 } else {
  return $MAX_CLIENTS - sv_spectator_slots();
 }
}

sub sv_gametype {
 return $config{'sv_gametype'}->get() unless defined $_[0];
 die "Unknown gametype\n" unless $_[0] ~~ [
  'ctf', 'tdm', 'dm', 'ictf', 'itdm', 'idm', 'ifrzctf', 'ifreeze', 'ifb'
 ];
 $config{'sv_gametype'}->set($_[0]);
}

# Avoid name clash with POSIX::pause
sub pause {
 server_pause @_ > 0 ? @_ : -1;
}

# Find the next free gid (ineffective; assumes gid basis to be powers of two)
sub free_gid {
 my $result = 1;
 $result <<= 1 
   while $result != 0 
         && find {
              $_->{'gid'} != $g_root && $_->{'gid'} & $result 
            } values %groups;
 die 'Gids exhausted' if $result == 0;
 return $result;
};

1;
