#!/usr/bin/perl -w
# -*- coding:utf-8 -*-

# Simple registration form, prints to files

use CGI; # qw(-no_debug :standard);
use CGI::Carp qw(fatalsToBrowser set_message);
set_message("For help, please send mail to the webmaster ([pz\@limsi.fr]), giving this error message and the time and date of the error.");
# Use of the encoding pragma is deprecated at /webvol/web/comparable/bucc2017/cgi-bin/download-sample.cgi line 9.
# use encoding 'utf8';
use utf8;			# use unicode expression in this script
use strict;

# our $Registration_Dir = "/limsi/users/pz/bucc2017-registration";
our $Registration_Dir = "/webvol/users/pz/bucc2017/registration";
our $Download_Dir = "..";
our $Base_Dir = "https://comparable.limsi.fr/bucc2017";
our $File_Pattern = "%0.3i.tab";
our $File_Type = ".tab";
my $Dataset_Pattern = "bucc2017-%s.%s-gold.tar.bz2";

my $MaxFileVersion = 1000;

#================================================================
# Message page
#================================================================

# Error message, stop the program
sub error_page {
    my($q, $message) = @_;
    print join('',
	       $q->header(-charset => "utf-8"),
	       $q->start_html(-title=>"Internal error of form processing program",
			      # -author=>"$Auteur",
			      -target=>'ProcessingError',
			      -BGCOLOR=>'#ffdfdf',
			      -lang => "en-US",), "\n",
	       $q->h1("Internal error of form processing program"), "\n",
	       $q->hr(), "\n",
	       $q->em("$message"), "\n",
	       $q->hr(), "\n",
	       $q->end_html) . "\n";
    exit;
}

# Returns a date of the form AAAA/MM/DD
sub DateTime {
    my($time) = @_;
    $time = time unless defined $time;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
        = localtime($time);
    $mon++;                     # month from 0
    $year += 1900;              # year on 4 digits
    # to quiet WarnIfDebuging :-)
    my(@ignore) = ($mday,$mon,$year,$wday,$yday,$isdst);
    @ignore = @ignore;          # removes warning :-/
    return sprintf("%0.4i/%0.2i/%0.2i %0.2i:%0.2i:%0.2i", $year, $mon, $mday, $hour, $min, $sec);
}

#================================================================
# Content pages
#================================================================

# standard tempate for this application
sub create_page {
    my ($q, $titre, $auteur, $MetaMotscles, $MetaContenu, $couleur,
	$contenu) = @_;

    return join('',
		$q->header('text/html'),
		$q->start_html(-title=>"$titre",
			       -author=>"$auteur",
#			 -base=>'true',
#			 -target=>'_blank',
			       -meta=>{'keywords'=>"$MetaMotscles",
				       'copyright'=>'copyright (c) 2017 PZ'},
#			 -style=>{'src'=>'/styles/style1.css'},
			       -BGCOLOR=>"$couleur"), "\n",

		$q->h1($titre), "\n",
		$q->hr(), "\n",
		$contenu, "\n",
		$q->hr(), "\n",
		$q->end_html) . "\n";
}

sub registration_form_contents {
    my ($q, $header, $footer) = @_;
    my $myself = $q->url;
    if ($Base_Dir =~ /^https:/) { # fix CGI.pm problem
	$myself =~ s/^http:/https:/;
    }
    return join("\n",
		$q->start_multipart_form(-method=>"POST",
					 -action=>$myself,
#			-encoding=>"multipart/form-data"
		),
		$header, "\n",
		$q->table(
		    $q->TR ($q->td($q->em("Given Name*:")), $q->td($q->textfield(-name=> 'given_name')),), "\n",
		    $q->TR ($q->td($q->em("Surname*:")), $q->td($q->textfield(-name=> 'surname')),), "\n",
		    $q->TR ($q->td($q->em("Email*:")), $q->td($q->textfield(-name=> 'email')),), "\n",
		    $q->TR ($q->td($q->em("Affiliation:")), $q->td($q->textfield(-name=> 'affiliation')),), "\n",
		    $q->TR ($q->td($q->em("Team name*:")), $q->td($q->textfield(-name=> 'team')),), "\n",
		    $q->TR ($q->td($q->em("Status:")), $q->td($q->popup_menu(
								  -name    => 'status',
								  -values  => [qw(Academic Company Government)],
								  # -default => 'Academic',
							      )),), "\n",
		    $q->TR ($q->td($q->em("Selected language pairs*:")), $q->td($q->checkbox_group(
										    -name    => 'langs',
										    -values  => [qw(de-en fr-en ru-en zh-en)],
										    # -disabled => [qw(zh-en)],
										    # -labels => {"zh-en" => "zh-en (soon)"},
										    # -default => 'Academic',
										)),), "\n",
		    $q->TR ($q->td($q->em("I am a*:")), $q->td($q->popup_menu(
								  -name    => 'nature',
								  -values  => [qw(robot human)],
							      )),), "\n",
		    $q->TR ($q->td(), $q->td($q->submit(-name=>'upload_button', -value=>'Send'))), "\n",
		),
		$q->p({-style=>"color:'red';"}, "(*) required field."), "\n",
		$footer, "\n",
		$q->end_form) . "\n";
}

sub dataset_row {
    my($q, $lp, $split) = @_;
    my $relative_url = sprintf($Dataset_Pattern, $lp, $split);
    my $full_url = full_path($relative_url, $Download_Dir);
    $q->TR($q->td($split), $q->td($q->em($lp)), $q->td($q->a({href=>$full_url}, $relative_url)));
}

sub download_page {
    my($q, $record_id, $langs) = @_;
    my @rows = ();
    for my $split (qw(sample training)) {
	push @rows, $q->TR
	    ($q->th("Split"), $q->th("Language pair"), $q->th("Dataset"));
	# for my $lp (qw(de-en fr-en ru-en zh-en)) {
	for my $lp (@$langs) {
	    push @rows, dataset_row($q, $lp, $split);
	}
    }
    join("\n",
	 $q->p("Registered as ", $q->em($record_id), "."),
	 $q->p("You can now download the following datasets:"),
	 $q->table(
	     join("\n", @rows),
	 ),
	 $q->p({-style=>"text-align: right; font-size: xx-small"}, "Last updated on 6 Oct 2017"),
	);
}

#================================================================
# File naming and creation
#================================================================
sub write_record_file {
    my($q, $filename, $content) = @_;

    # my $filename = full_path($relative_name, $Registration_Dir);
    open(FILE, ">:utf8", $filename) ||
	error_page($q, "Could not write registration file '$filename' ($!)\n");
    print FILE $content;
    print FILE "\n"		# ajoute un \n final si absent
	unless $content =~ /\n$/;
    close FILE;
}


# Calcule un nom à employer en local à partir du nom distant
sub get_file_name_for_record {
    my($q, $informations, $file_pattern) = @_;
    my $record_name = join("_", @$informations);
    # warn "record_name='$record_name'\n";
    # end of name, must contain only letter characters
    $record_name =~ s{\W}{_}g;
    # warn "cleaned record_name='$record_name'\n";
    my $path_pattern = join("/", $Registration_Dir, join("-", $record_name, $file_pattern));
    # warn "path_pattern='$path_pattern'\n";
    for (my $number=1; $number <$MaxFileVersion; $number++) {
	my $file = sprintf($path_pattern, $number);
	if (! -f $file) {
	    return $file;
	}
    }
    return sprintf($path_pattern, $MaxFileVersion + 1); # if overflow, overwrite max number (do not overwrite earlier records)
}

sub full_path {
    my($filename, $base_dir) = @_;
    $base_dir = $Base_Dir unless defined($base_dir);
    join("/", $base_dir, $filename);
}


#================================================================
# Collect form contents and execute action
#================================================================

sub process_answer {
    my($q) = @_;
    # print $q->Dump;
    my($surname, $given_name, $email, $affiliation, $team, $status, $nature) =
	map { my $str = (exists($q->Vars->{$_}) ? $q->Vars->{$_} : ""); $str =~ s/\s+//; $str =~ s/\s+$//; utf8::upgrade($str); $str; } qw(surname given_name email affiliation team status nature);
    my @langs = $q->multi_param('langs');
    my $remote_addr = $q->remote_addr;
    my $referer = $q->referer;
    my $nb_non_empty = grep { $_ ne ""; } ($surname, $given_name, $email, $affiliation, $team, $status, $nature);
    # warn "'", join("', '", $surname, $given_name, $team), "'\n";
    if (($surname ne "") and ($given_name ne "") and ($email ne "") and ($team ne "") and (@langs > 0) and ($nature ne "") and ($nature ne "robot")) {
	my $filename = get_file_name_for_record($q, [$surname, $given_name, $team], $File_Pattern);
	# warn "process_answer: writing filename '$filename'\n";
	write_record_file($q, $filename, join("", join("\t", ($surname, $given_name, $email, $affiliation, $team, $status, join(',', @langs), $nature, $referer, $remote_addr, DateTime())), "\n"));
	my($file_id) = (split(/\//, $filename))[-1];
	return ($file_id, $nb_non_empty, "", \@langs);
    }
    elsif ($nb_non_empty > 0) {
	# warn "process_answer: not enough parameters\n";
	return ("", $nb_non_empty, "Missing required parameter(s)", \@langs);
    }
    else {
	return ("", 0, "", \@langs);
    }
}

#================================================================
# Lecture de la requête reçue et calcul de la réponse
#================================================================

sub registration_form_page {
    my($q) = @_;
    return ;
}

sub my_cgi_handler {
    my $q = new CGI;
    my ($saved_record, $nb_fields, $message, $langs) = process_answer($q);
    if ($saved_record) {
	$saved_record =~ s/$File_Type$//;
	create_page($q,
		    "BUCC 2017 Shared Task dataset download registration form",
		    'pz@limsi.fr',
		    "BUCC, 2017, Datasets, Registration",
		    "BUCC 2017 Shared Task dataset registration form",
		    '#8F8FFF',
		    download_page($q, $saved_record, $langs));
    }
    else {
	create_page($q,
		    "BUCC 2017 Shared Task dataset download page",
		    'pz@limsi.fr',
		    "BUCC, 2017, Datasets, Registration, Download",
		    "BUCC 2017 Shared Task dataset download page",
		    '#8F8FFF',
		    registration_form_contents($q, $q->p({-style=>"color: red;"}, $message), $q->p({-style=>"text-align: right; font-size: xx-small;"}, sprintf("(%i fields provided)", $nb_fields))));
    }
}

#================================================================
# Calcul et impression de la réponse à la requête reçue
#================================================================

print my_cgi_handler();