#!@WHICHPERL@
=head1 NAME

tomtom_webservice - Run tomtom in a restricted mode and create an index webpage.

=head1 SYNOPSIS

tomtom_webservice [options] <query motifs> <motif databases>

  Options:
    -dist (pearson|ed|sandelin)   distance function to use; default pearson
    -ev <evalue>                  evalue threshold; default 10; not usable with -qv
    -qv <qvalue>                  qvalue threshold; not usable with -ev
    -m <name>                     filter query motifs by name (id); repeatable
    -mi <index>                   filter query motifs by file order; repeatable
    -uptargets <file>             uploaded target motifs
    -incomplete_scores            don't included unaligned parts of the motif in scoring
    -niced                        run tomtom niced
    -help                         brief help message

  Distance Functions
    pearson - Pearson correlation coefficient
    ed - Euclidean distance
    sandelin - Sandelin-Wasserman similarity function

  Motif Databases
    The motif databases may be specified as a pattern using * as a wildcard.
=cut

use strict;
use warnings;

use Cwd qw(getcwd abs_path);
use Fcntl qw(SEEK_SET);
use File::Basename qw(fileparse);
use File::Spec::Functions qw(catfile tmpdir);
use File::Temp qw(tempfile);
use Getopt::Long;
use Pod::Usage;

use lib qw(@PERLLIBDIR@);

use ExecUtils qw(stringify_args invoke);
use MemeWebUtils qw(is_safe_name add_status_msg update_status loggable_date write_invocation_log);
use Globals;

# constants
my $tmpdir = '@TMP_DIR@';
# use the perl default if none is supplied or the replace fails
$tmpdir = &tmpdir() if ($tmpdir eq '' || $tmpdir =~ m/^\@TMP[_]DIR\@$/);
my $dbdir = '@MEMEDIR@/db/motif_databases';
my $workdir = getcwd;

# variables for the service invocation log
my $log_args = stringify_args(@ARGV);
my $log_date = loggable_date();
my $log_file = 'tomtom-log';

# error files
my $messages = "messages.txt";

#status page
my $file_list;
my @arg_errors = ();
my $msg_list = [];
my $program = 'TOMTOM';
my $page = 'index.html';
my $refresh = 10;

# required parameters
my $queries;
my @dbtargets;
# option defaults
my $uptargets = undef;
my $dist = 'pearson';
my $qv = undef;
my $ev = undef;
my @query_names = ();
my @query_indexes = ();
my $incomplete_scores = 0; #FALSE
my $niced = 0; #FALSE
my $help = 0; #FALSE
# derived
my @targets = ();

add_status_msg('Parsing arguments', $msg_list);

# redirect stderr so we can get the error message from GetOpts
my ($err_old, $err_tmp, $opts_ok, $opts_msg);
open($err_old, ">&STDERR") or die("Can't dup STDERR: $!");
$err_tmp = tempfile('GetOptions_XXXXXXXXXX', DIR => $tmpdir, UNLINK => 1); # make a temporary file
open(STDERR, '>&', $err_tmp) or die("Can't redirect STDERR: $!");
# parse options
$opts_ok = GetOptions(
  'dist=s' => \$dist,
  'ev=f' => \$ev,
  'qv=f' => \$qv,
  'm=s' => \@query_names,
  'mi=i' => \@query_indexes,
  'uptargets=s' => \$uptargets,
  'incomplete_scores' => \$incomplete_scores,
  'niced' => \$niced,
  'help|?' => \$help
);
($queries, @dbtargets) = @ARGV;
# display help
pod2usage(1) if $help;
# reset stderr and get the error message if any
open(STDERR, ">&", $err_old) or die("Can't reset STDERR: $!");
seek($err_tmp, 0, SEEK_SET);
while ($opts_msg = <$err_tmp>) {
  chomp($opts_msg);
  push(@arg_errors, $opts_msg);
}
close($err_tmp);

# check query motifs
unless (defined($queries)) {
  push(@arg_errors, "No query motifs provided.");
} else {
  $queries = fileparse($queries);
  if (not is_safe_name($queries)) {
    push(@arg_errors, "Query motifs \"$queries\" does not fit allowed ".
      "file name pattern.");
  } elsif (not -e $queries) {
    push(@arg_errors, "Query motifs \"$queries\" does not exist.");
  } 
}
# check target motifs
if (defined($uptargets)) {
  $uptargets = fileparse($uptargets);
  if (not is_safe_name($uptargets)) {
    push(@arg_errors, "Value \"$uptargets\" invalid for option uptargets ".
      "(does not fit allowed file name pattern)");
  } elsif (not -e $uptargets) {
    push(@arg_errors, "Value \"$uptargets\" invalid for option uptargets ".
      "(file does not exist)");
  } else {
    push(@targets, $uptargets);
  }
}
if (@dbtargets) {
  # The expansion must be evaluated in the database directory
  chdir($dbdir);
  my @expanded_targets = glob(join(' ', @dbtargets));
  chdir($workdir);
  # check that the expanded files really are in the db dir
  for (my $i = 0; $i < scalar(@expanded_targets); $i++) {
    $expanded_targets[$i] = fileparse($expanded_targets[$i]);
    if (-e catfile($dbdir, $expanded_targets[$i])) {
      push(@targets, catfile('db',$expanded_targets[$i]));
    }
  }
}
unless (@targets) {
  push(@arg_errors, "No target motifs provided.");
}
# check motif comparison function
if (defined($dist)) {
  if ($dist ne 'pearson' && $dist ne 'ed' && $dist ne 'sandelin') {
    push(@arg_errors, "Value \"$dist\" invalid for option dist ".
      "(must be pearson, ed or sandelin)");
  }
}

# check qvalue threshold
if (defined($qv)) {
  if ($qv <= 0 || $qv > 1) {
    push(@arg_errors, "Value \"$qv\" invalid for option qv ".
      "(not a valid q-value)");
  }
}
# check evalue threshold
if (defined($ev)) {
  if ($ev <= 0) {
    push(@arg_errors, "Value \"$ev\" invalid for option ev ".
      "(not a valid E-value)");
  }
}
# check both are not defined simultaneously
if (defined($qv) && defined($ev)) {
  push(@arg_errors, "Option ev incompatable with option qv");
}
# check motif names are safe names
for (my $i = 0; $i < scalar(@query_names); $i++) {
  if (not is_safe_name($query_names[$i])) {
    push(@arg_errors, "Value \"".$query_names[$i]."\" invalid for option m ".
      "(does not fit allowed command-line safe pattern)");
  }
}

$opts_ok = 0 if (scalar(@arg_errors) > 0);
foreach my $arg_error (@arg_errors) {
  print STDERR $arg_error, "\n";
  add_status_msg($arg_error, $msg_list);
}

# setup status page
$file_list = [
    {file => 'tomtom.html', desc => 'TOMTOM html output'},
    {file => 'tomtom.xml', desc => 'TOMTOM xml output'}, 
    {file => 'tomtom.txt', desc => 'TOMTOM plain text output'},
    {file => $queries, desc => 'Input query motifs'},
    {file => $uptargets, desc => 'Uploaded target motifs'}
];

if ($opts_ok) {
  add_status_msg('Arguments ok', $msg_list);
} else {
  add_status_msg("Error parsing arguments", $msg_list);
}

update_status($page, $program, ($opts_ok ? $refresh : 0), $file_list, 
    $msg_list, ($opts_ok ? "Starting" : "Error"));

# exit if there was an error reading the arguments
unless ($opts_ok) {
  write_invocation_log($log_file, $log_date, $log_args);
  pod2usage(2);
}

# Run TOMTOM
my @filter = ((map {('-m', $_)} @query_names), (map {('-mi', $_)} @query_indexes));
my @tomtom_args = ( '-no-ssc', '-oc', '.', '-verbosity', 1, '-min-overlap', 5, @filter);
push(@tomtom_args, '-dist', $dist) if (defined($dist));
push(@tomtom_args, '-evalue', '-thresh', $ev) if (defined($ev));
push(@tomtom_args, '-thresh', $qv) if (defined($qv));
push(@tomtom_args, '-incomplete-scores') if ($incomplete_scores);
push(@tomtom_args, $queries, @targets);
add_status_msg('Starting tomtom<br><code>' . stringify_args('tomtom', @tomtom_args) . '</code>', $msg_list);

update_status($page, $program, $refresh, $file_list, $msg_list, "Starting");

my ($time, $status_code);
# create the symlink
symlink($dbdir, 'db') unless $uptargets;
# run the program
$status_code = invoke(
  PROG => 'tomtom', 
  ARGS => \@tomtom_args, 
  BIN => '@BINDIR@', 
  ALL_FILE => $messages, 
  TIME => \$time,
  NICE => ($niced ? 19 : undef));
# remove the simlink
unlink('db') unless $uptargets;

my $status_msg;
if ($status_code != 0) {
  if ($status_code == -1) {
    $status_msg = "tomtom failed to run";
  } elsif ($status_code & 127) {
    $status_msg = "tomtom process died with signal " . 
        ($status_code & 127) . ", " . 
        (($status_code & 128) ? 'with' : 'without') . " coredump";
  } else {
    $status_msg = "tomtom exited with error code " . ($status_code >> 8);
  }
  print STDERR $status_msg;
  push(@{$file_list}, {file => $messages, desc => 'Error Messages'});
} else {
  $status_msg = 'tomtom ran successfully in ' . 
      (int($time * 100 + 0.5) / 100) . ' seconds';
  push(@{$file_list}, {file => $messages, desc => 'Warning Messages'});
}
add_status_msg($status_msg, $msg_list);

update_status($page, $program, 0, $file_list, $msg_list, 
    ($status_code ? "Error" : "Done"));


write_invocation_log($log_file, $log_date, $log_args);
exit(1) if $status_code;
1;