package RemoteServer;

require 5.006; # Funktion "our" und anderes geht erst ab 5.6!

use strict;

BEGIN
{
  use Exporter ();
  our ($VERSION, $version, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

  $version     = '2010.0825';
  $VERSION     = $version+0;

  @ISA         = qw(Exporter);
}
our @EXPORT_OK;

use FileHandle;
use IO::Socket 1.18; # Ab 1.18 ist autoflush per default aktiv.
use Net::hostent;    # for OO version of gethostbyaddr

my $MAX_BUFFER = 1024*1024;

my $client;
my %sub = ();
my $restart_after_quit = 0;

sub SetLoggingAndExitFunctions
{
  # Parameter: Hash mit den Keys "exit", "logprint", "debug", "warning",
  #            "error", "logdie" und als Werte Referenzen auf Funktionen.
  # Return: -
  # Beispiel: SetLoggingAndExitFunctions(error=>\&myexit,warning=>\&mywarn);
  #
  my %param = @_;
  my $key;
  foreach $key (keys %param)
  {
    next unless $key =~ /exit|logprint|debug|warning|error|logdie/;
    $sub{$key} = $param{$key};
  }
}


sub SetRestartAfterQuit
{
  logprint("Es wird nach QUIT ein Neustart von '$0' unter der gleichen PID ($$) erfolgen.\n");
  $restart_after_quit = 1;
}


sub new
{
  # Parameter: Port, Liste der erlaubten Rechner
  # Return:    Objekt
  #
  my $port = shift;
  my $self = {};

  $self->{AUTHORIZED_HOSTS} = [ @_ ];

  unless (defined $port)
  {
    carp("RemoteServer::new() ohne Parameter aufgerufen!\n");
    myexit();
  }

  my $server = IO::Socket::INET->new( Proto     => 'tcp',
				      LocalPort => $port,
				      Listen    => SOMAXCONN,
				      Reuse     => 1);

  logdie("Kann Server nicht starten: $!\n") unless $server;
  logprint("Server nimmt Clientanfragen entgegen.\n");

  $self->{SERVER} = $server;
  bless $self, 'RemoteServer';
  return $self;
}


sub Run
{
  # Parameter: Objekt
  # Return:    -
  # Start des Servers in einer Endlosschleife
  #
  my $self = shift;
  my $server = $self->{SERVER};
  my @authorized_hosts = @{$self->{AUTHORIZED_HOSTS}};

  while ($client = $server->accept())
  {
    my $hostinfo = gethostbyaddr($client->peeraddr);
    my $remotehost;
    if (defined $hostinfo)
    {
      $remotehost = $hostinfo->name;
    }
    else
    {
      $remotehost = $client->peerhost;
    }
    logprint("Verbindung von $remotehost um ",scalar localtime,"\n");

    # Authentifizierung
    unless (grep(/$remotehost/, @authorized_hosts))
    {
      logprint("Verbindung nicht erlaubt.\n");
      sendText("Verbindung nicht erlaubt.");
      sendTextEnd();
      sendERROR();
      close $client;
      next;
    }

COMMAND: while (<$client>)
    {
      # Leerzeilen einfach ignorieren
      next COMMAND unless /\S/;
      logprint("INPUT: $_");
      ##########
      # EXIT oder QUIT
      if (/^exit|^quit/io)
      {
	logprint("EXIT\n");
	if ($restart_after_quit)
	{
	  logprint("Es erfolgt der Neustart von '$0' unter der gleichen PID ($$), der durch RESTART-AFTER-QUIT angefordert war.\n");
	  sleep 1; # Sonst Fehler!
	  exec $0;
	}
	last COMMAND;
      }
      ##########
      # RESTART-AFTER-QUIT
      if (/^restart-after-quit/io)
      {
	logprint("RESTART-AFTER-QUIT\n");
	SetRestartAfterQuit();
	sendText("Es wird nach QUIT ein Neustart von '$0' unter der gleichen PID ($$) erfolgen.\n");
	sendTextEnd();
	sendOK();
	next COMMAND;
      }
      ##########
      # RESTART
      if (/^restart/io)
      {
	logprint("RESTART\n");
	logprint("Neustart von '$0' unter der gleichen PID ($$)...\n");
	exec $0;
      }
      ##########
      # COMMAND kommando [ parameter ]
      elsif (/^command\s+(.+?)[\r\n]*$/io)
      {
	my $command = $1;
	my @output;
	my $ret;
	logprint("COMMAND: '$command'\n");
	@output = `$command </dev/null 2>&1`;
	$ret = $?>>8;
	logprint("COMMAND-OUTPUT: '",@output,"'\n");
	logprint("COMMAND-RETURN-CODE: '",$ret,"'\n");
	if ($ret)
	{
	  sendTextError("ERROR: $!\n") if ($! ne '');
	  sendTextError("ERROR: @output\n") if (@output);
	  sendTextEnd();
	  sendERROR();
	  undef $!;
	}
	else
	{
	  sendText(join('',@output));
	  sendTextEnd();
	  sendOK();
	}
      }
      ##########
      # PERL perlcode
      elsif (/^perl\s+(.+?)[\r\n]*$/io)
      {
	my $code = $1;
	logprint("PERL: '$code'\n");
	my $return = eval $code;
	if ($@)
	{
	  sendTextError("ERROR: $@\n");
	  sendTextEnd();
	  sendERROR();
	}
	else
	{
	  sendText($return);
	  sendTextEnd();
	  sendOK();
	}
      }
      ##########
      # FILE filename size [ permission=... owner=... group=... ]
      elsif (/^file\s+[\w\.\-\/\+\:]+\s+\d+(\s+.+)*[\r\n]*$/io)
      {
	my @zeile  = split(' ',$_);
	shift @zeile; # "FILE" entfernen.
	my $file   = shift @zeile;
	my $size   = shift @zeile;
	my $owner  = '';
	my $input_owner  = '';
	my $group  = '';
	my $input_group  = '';
	my $perm   = '';
	foreach (@zeile)
	{
	  if    (/owner=(.+)/)      { $owner = $1; next; }
	  elsif (/group=(.+)/)      { $group = $1; next; }
	  elsif (/permission=(.+)/) { $perm  = $1; next; }
	}
	logprint("FILE $file $size permission=$perm owner=$owner ".
		 "group=$group\n");
	# Erst mal ein möglicherweise vorhandenes File löschen.
	# Sonst könnte es passieren, dass man Symlinks überschreibt!
	if (-e $file)
	{
	  unlink $file;
	}
	my $fh = new FileHandle;
	open($fh, ">$file") || do
	{
	  sendTextError("Kann das File '$file' nicht zum Schreiben oeffnen!\n");
	  sendTextEnd();
	  sendERROR();
	  next COMMAND;
	};

	# Wenn kein Owner angegeben ist, dann den Benutzer nehmen, der dieses
	# Programm ausführt.
	if ($owner eq '')
	{
	  $owner = $>; # Effektive UID
	}
	else
	{
	  $input_owner = $owner;
	  if (! defined ($owner = getpwnam($owner)) )
	  {
	    $owner = $input_owner;
	    # Prüfen, ob der Benutzer als numerische UID angegeben wurde.
	    # Verhalten ist analog zu chown programmiert, d.h. wenn eine
	    # Zahl angegeben wurde, dann wird das einfach übernommen!
	    if ( ! ($owner =~ m/^[0-9]+$/) )
	    {
	      sendTextError("Den Benutzer bzw. numerische UID '$input_owner' gibt es nicht!\n");
	      sendTextEnd();
	      sendERROR();
	      next COMMAND;
	    }
	  }
	}
	# Wenn keine Gruppe angegeben ist, dann die Standard-Gruppe des
	# Benutzers nehmen.
	if ($group eq '')
	{
	  $group = (getpwnam(getpwuid($owner)))[3];
	}
	else
	{
	  $input_group = $group;
	  if (! defined ($group = getgrnam($group)) )
	  {
	    $group = $input_group;
	    # Prüfen, ob die Gruppe als numerische GID angegeben wurde.
	    # Verhalten ist analog zu chgrp programmiert, d.h. wenn eine
	    # Zahl angegeben wurde, dann wird das einfach übernommen!
	    if ( ! ($group =~ m/^[0-9]+$/) )
	    {
	      sendTextError("Die Gruppe bzw. numerische GID '$input_group' gibt es nicht!\n");
	      sendTextEnd();
	      sendERROR();
	      next COMMAND;
	    }
	  }
	}
	logprint("FILE $file $size permission=$perm owner=$owner ".
		 "group=$group\n");
	# Zuerst Owner, dann Permissions ändern, da andernfalls beim
	# "chown root" das zuvor gesetzte s-Bit wieder weg ist.
	if ($owner ne '')
	{
	  chown($owner, $group, $file) || do
	  {
	    sendTextError("Kann den Besitzer/Gruppe fuer '$file' nicht setzen!\n");
	    sendTextEnd();
	    sendERROR();
	    next COMMAND;
	  };
	}
	if ($perm  ne '')
	{
	  chmod(oct($perm), $file) || do
	  {
	    sendTextError("Kann die Rechte fuer '$file' nicht setzen!\n");
	    sendTextEnd();
	    sendERROR();
	    next COMMAND;
	  };
	}
	
	# File empfangen
	sendText("File zum Empfang geoeffnet. Warte auf Daten...\n");
	sendTextEnd();
	sendOK();
	my $input = '';
	my $buf_size;
	my $noch_zu_empfangen = $size;
	while ($noch_zu_empfangen > 0)
	{
	  $buf_size = $noch_zu_empfangen >= $MAX_BUFFER
	  ? $MAX_BUFFER
	  : $noch_zu_empfangen;
	  read($client, $input, $buf_size) || do
	  {
	    sendTextError("Fehler beim Empfangen von '$file'! Verbindungsabbruch?\n");
	    sendTextEnd();
	    sendERROR();
	    next COMMAND;
	  };
	  print($fh $input) || do
	  {
	    sendTextError("Fehler beim Schreiben in '$file'!\n");
	    sendTextEnd();
	    sendERROR();
	    # Restlichen Input vom Client noch lesen, da der Client sonst nur
	    # ein "Broken pipe" bekommt.
	    while ($noch_zu_empfangen > 0)
	    {
	      $buf_size = $noch_zu_empfangen >= $MAX_BUFFER
	      ? $MAX_BUFFER
	      : $noch_zu_empfangen;
	      read($client, $input, $buf_size);
	      $noch_zu_empfangen = $noch_zu_empfangen - $buf_size;
	      debug("$noch_zu_empfangen\n");
	    }
	    next COMMAND;
	  };
	  $noch_zu_empfangen = $noch_zu_empfangen - $buf_size;
	}
	close($fh) || do
	{
	  sendTextError("Fehler beim Schliessen von '$file'!\n");
	  sendTextEnd();
	  sendERROR();
	  next COMMAND;
	};
	sendOK();
      }
      ##########
      # GET filename
      elsif (/^get\s+([\w\.\-\/]+)[\r\n]*$/io)
      {
	my $file = $1;
	logprint("GET $file\n");
	my $fh = new FileHandle;
	open($fh, "<$file") || do
	{
	  sendTextError("Kann das File '$file' nicht zum Lesen oeffnen!\n");
	  sendTextEnd();
	  sendERROR();
	  next COMMAND;
	};
	my $size = -s $fh;
	print ($client "$size\n") || do
	{
	  logprint("Fehler beim Senden zum Client.\n");
	  close $client;
	  next CLIENT;
	};
	if ($size > 0)
	{
	  while(read($fh, $_, $MAX_BUFFER))
	  {
	    print ($client $_) || do
	    {
	      sendTextError("Fehler beim Senden von '$file'!\n");
	      sendTextEnd();
	      sendERROR();
	      next COMMAND;
	    };
	  }
	}
	close $fh; # Nur lesend geöffnet => Kein Fehler zu erwarten.
	sendOK();
      }
      ##########
      # VERSION
      elsif (/^version[\r\n]*$/io)
      {
	logprint("VERSION\n");
	sendText("$RemoteServer::version");
	sendTextEnd();
	sendOK();
      }
      ##########
      # HELP
      elsif (/^help[\r\n]*$/io)
      {
	logprint("HELP\n");
	sendText("COMMAND command
FILE filename size [ permission=... owner=... group=... ]
GET filename
PERL perlcode
EXIT
QUIT
RESTART
RESTART-AFTER-QUIT
VERSION\n");
	sendTextEnd();
	sendOK();
      }
      else
      {
	sendTextError("Unbekanntes Kommando oder nicht erlaubter ".
		      "Parameter.\n");
	sendTextEnd();
	sendERROR();
      }
    }
    close $client;
    logprint("Verbindung zu $remotehost um ",scalar localtime," beendet.\n");
  }

  # Der accept() wurd das Signal und den Aufruf der Funktion
  # SetRestartAfterQuit() unterbrochen.
  if ($restart_after_quit)
  {
    logprint("Es erfolgt der Neustart von '$0' unter der gleichen PID ($$), der durch RESTART-AFTER-QUIT angefordert war.\n");
    exec $0;
  }
  else
  {
    error("$!\n");
    error("Ende von accept(). Das sollte nicht sein!\n");
    myexit();
  }
}

######################################################################
### Unterprogramme
######################################################################

sub EscapeText
{
  # Da das Ende einer Verbindung durch einen einzelnen "." in einer Zeile
  # angezeigt wird, muss im übertragenen Text soetwas escaped werden.
  # Einfacher Ansatz: Aus "." mache ".."
  my $text = shift;
  $text =~ s/\./../gos;
  return $text;
}


sub UnEscapeText
{
  # Umkehrung von EscapeText: Aus ".." wird "."
  my $text = shift;
  $text =~ s/\.\././gos;
  return $text;
}


sub sendOK
{
  print $client "OK\n";
}


sub sendERROR
{
  print $client "ERROR\n";
}


sub sendTextError
{
  my $text = shift;
  my $text_esc = EscapeText($text);

  print $client "$text_esc";
  warning($text);
}


sub sendText
{
  my $text = shift;
  my $text_esc = EscapeText($text);

  print $client "$text_esc";
}


sub sendTextEnd
{
  print $client "\n.\n";
}


######################################################################
### Debug, Logging, Exit, ...
######################################################################

sub myexit   { &{$sub{exit}}     if defined $sub{exit};     }
sub logprint { &{$sub{logprint}} if defined $sub{logprint}; }
sub debug    { &{$sub{debug}}    if defined $sub{debug};    }
sub warning  { &{$sub{warning}}  if defined $sub{warning};  }
sub error    { &{$sub{error}}    if defined $sub{error};    }
sub logdie   { &{$sub{logdie}}   if defined $sub{logdie};   }

1;