#!btred -i start_srvr --no-save --allow-switch-context
# -*- cperl -*-

#include "print.btred"

{
package TredMacro;

use warnings;
use strict;
use Encode ();

my %opts = @ARGV;
my @permitted_paths = split(/:/, $opts{'--allow-paths'});
my $port = ($opts{'--port'} || 8070);
my $host = ($opts{'--host'} || 'localhost');

our $cache_dir = $opts{'--cache-dir'};

!$cache_dir or (-d $cache_dir) or die "Cache directory $cache_dir must exist!\n";


our $permitted_paths_re = '^(?:'.join('|',@permitted_paths).')/';

sub start_srvr {
  if (!@permitted_paths) {
    die "No data paths enabled. Use --allow-paths to allow serving trees from files in a subtrees!\n";
  }
  print STDERR "Starting tree print service on $host:$port\n";
  my $server = TrEd::Print::Server->new($port);
  $server->host($host);
  $server->run();
}

sub on_get_node_style {
  my ($treeview,$node,$styles,$win)=@_;
  my $ret = &main::onGetNodeStyle;

  # append the ID as a -tag to every node
  my $tag = GetStyles($styles,'Node','-tag');
  $tag.=',' if $tag;
  my $type = $node->type;
  my ($id_attr) = $type && $type->find_members_by_role('#ID');
  my $id = $id_attr && $node->{ $id_attr->get_name };
  if ($id) {
    $tag .= qq{#$id};
    AddStyle($styles,'Node',-tag=>$tag);
  }
  return $ret;
}

sub make_pmltq {
  my ($positions,%opts)=@_;
  if (exists &Tree_Query::nodes_to_pmltq) {
    my $cur = CurrentFile();
    my @open_files = ($cur ? ($cur, GetSecondaryFiles($cur)) : ());
    my %cur_fsfiles; @cur_fsfiles{@open_files}=();
    # my $keep_cur;
    my %fsfiles;
    my @new_fsfiles;
    foreach my $f (map $_->[0], @$positions) {
      next if exists $fsfiles{$f};
      my ($open) = grep { Treex::PML::IO::is_same_filename($_->filename, $f) }
	@open_files;
      if ($open) {
	# $keep_cur=1 if !$keep_cur and exists($cur_fsfiles{$open});
	$fsfiles{$f}=$open;
      } else {
	my $fsfile = Treex::PML::Factory->createDocumentFromFile(
	  $f,
	  {
	    encoding => $TrEd::Convert::inputenc,
	    backends => [Backends()]
	   });
	$fsfile->changeFilename($f);
	eval { OpenSecondaryFiles($fsfile); };
	print STDERR "$@\n" if $@;
	unless ($fsfile and $fsfile->lastTreeNo and $Treex::PML::FSError==0) {
	  my $err = $@ || $! || 'unknown error';
	  warn("Failed to open $f: $err\n");
	  return;
	}
	my @new = ($fsfile, GetSecondaryFiles($fsfile));
	push @new_fsfiles, @new;
	push @open_files, @new;
	$fsfiles{$_->filename}=$_ for @new; # including $fsfile
	$fsfiles{$f}=$fsfile; # $f may be different from $fsfile->filename
      }
    }
    my @nodes;
    for my $pos (@$positions) {
      my $win = { FSFile => $fsfiles{$pos->[0]} };
      unless (TrEd::Utils::applyFileSuffix($win,$pos->[1]) and $win->{currentNode}) {
	warn "Didn't find node [@$pos, @{[%$win]}]\n";
	return;
      }
      push @nodes, [ $win->{currentNode}, $win->{FSFile} ];
    }
    print STDERR "generating query";
    return Tree_Query::nodes_to_pmltq(\@nodes,\%opts);
  }
  print STDERR "Method nodes_to_pmltq not available\n";
  return;
}

sub make_svg {
  my ($f,%opts)=@_;
  # TODO: implement complete caching
  my $cur = CurrentFile();
  my ($open) = grep { Treex::PML::IO::is_same_filename($_->filename, $f) }
    ($cur ? ($cur, GetSecondaryFiles($cur)) : ());
  # primitive caching of the last file

  if ($cur and !$open) {
    CloseFile();
  }
  if (!$open or $open!=$cur) {
    SetCurrentStylesheet(STYLESHEET_FROM_FILE());
    Open($f) || return;
  }
  undef $open;
  undef $cur;
  print_trees({
    '-no-hooks' => 1,
    -format => 'SVG',
    -toFile => 1,
    -onGetNodeStyle => \&on_get_node_style,
    %opts,
  });
  return 1;
}

package TrEd::Print::Server;
use base qw(HTTP::Server::Simple::CGI);
use URI;
use URI::file;
use Digest::MD5 qw(md5_hex);
use Fcntl;

sub handle_request {
  my ($self, $cgi) = @_;
  my $path = $cgi->path_info();
  if ($path eq '/svg') {
    serveSVG($self,$cgi);
  } elsif ($path eq '/pmltq') {
    servePMLTQ($self,$cgi);
  } else {
    notFound($cgi);
  }
}

sub notFound {
  my ($cgi)=@_;
  print "HTTP/1.0 404 Not found\r\n";
  print $cgi->header,
    $cgi->start_html('Not found'),
    $cgi->h1('Not found'),
    $cgi->end_html;
}

sub serverError {
  my ($cgi)=@_;
  print "HTTP/1.0 500 Internal server error\r\n";
  print $cgi->header,
    $cgi->start_html('Internal server error'),
    $cgi->h1('Error occurred while processing request!'),
    $cgi->end_html;
}

sub serveSVG {
  my ($self,$cgi) = @_;             # Net::HTTPServer::Request object
  my $path = $cgi->param('file');
  my $sentence = $cgi->param('sentence') ? 1 : 0;
  my $fileinfo = $cgi->param('fileinfo') ? 1 : 0;
  my $tree_no = int($cgi->param('tree_no')||0) || 1;
  my $no_cache = int($cgi->param('no_cache')||0);
  my $use_svg_desc_and_title = int($cgi->param('dt')||0) || 1;
  unless ($path) {
    print STDERR '['.localtime()."] No path!\n";
    return notFound($cgi);
  }
  $path=~s/\.svg$//;
  $path = URI->new($path)->canonical->as_string;
  if ($path=~m{/\.\./} or $path !~ $permitted_paths_re) {
    print STDERR '['.localtime()."] Path $path not permitted\n";
    return notFound($cgi);
  }
  print STDERR '['.localtime()."] Serving $path\n";
  my ($fh,$svg_name,$unlink,$cached);
  if (!$no_cache and $cache_dir) {
    $svg_name = File::Spec->rel2abs(md5_hex($path).".${tree_no}.svg",$cache_dir);
    if ((-f $svg_name) and (-s $svg_name) and (((stat($path))[9])<((stat($svg_name))[9])) ) {
      open $fh, '<:bytes', $svg_name;
      $cached = 1;
    } else {
      unless (sysopen($fh, $svg_name, (O_RDWR|O_CREAT), 0600)) {
	print STDERR "Failed to create $svg_name: $!";
	return serverError($cgi);
      }
    }
  } else {
    $fh = File::Temp->new()
      or return serverError($cgi);
    $svg_name = $fh->filename;
    $unlink = 1;
  }
  if (!$cached) {
    unless (TredMacro::make_svg($path,
				-filename => $svg_name,
				-range => $tree_no,
				-sentenceInfo => $sentence,
				-fileInfo => $fileinfo,
				-extraOptions => {
				  use_svg_desc_and_title => $use_svg_desc_and_title,
				}
			       )) {
      unlink $fh;
    }
  }
  binmode(select());
  print "HTTP/1.0 200 OK\r\n";
  print $cgi->header(-type => 'image/svg+xml',
		     # -Content_length => ((stat($fh))[7]),
		    );
  {
    local $/;
    print while <$fh>;
  }
  unlink $fh if $unlink;
  close $fh;
}

sub servePMLTQ {
  my ($self,$cgi) = @_;             # Net::HTTPServer::Request object
  my @names = split(/,/,$cgi->param('r')||'');
  my $paths = $cgi->param('p');
  my @paths = $paths ? split(/\|/, $paths) : ();
  unless (@paths) {
    print STDERR '['.localtime()."] No path!\n";
    return notFound($cgi);
  }
  my @positions;
  foreach my $p (@paths) {
    my ($path, $goto)=TrEd::Utils::parseFileSuffix($p);
    $path = URI->new($path)->canonical->as_string;
    if ($path=~m{/\.\./} or $path !~ $permitted_paths_re) {
      print STDERR '['.localtime()."] Path $path not permitted\n";
      return notFound($cgi);
    } elsif (!$goto) {
      print STDERR '['.localtime()."] Path $p does not contain an address\n";
      return notFound($cgi);
    }
    push @positions, [$path,$goto];
  }
  my $pmltq = TredMacro::make_pmltq(
    \@positions,
    (@names ? (reserved_names => {map {$_=>1} @names}) : ()),
   );
  print STDERR '['.localtime()."] Serving PMLTQ for $paths: $pmltq\n";
  if (!defined $pmltq) {
    print "HTTP/1.0 500 Internal Server Error\r\n\r\n";
    return;
  } else {
    binmode(select());
    Encode::_utf8_off($pmltq);
    print "HTTP/1.0 200 OK\r\n";
    print $cgi->header(-type => 'text/plain',
		       -charset => 'UTF-8',
		       # -Content_length => ((stat($fh))[7]),
		      );
    print $pmltq;
  }
}

}

1;
