#!/usr/local/bin/perl -wT

=pod

=head1 NAME

Twgyro detailed visibility tool

=head SYNOPSIS

    twogyro.pl

Runs as a cgi script

=head1 DESCRIPTION

This script runs through the web using the cgi protocol. It extracts
two gyro visibility data for an eleven day window surrounding the
specified date. It presents the data as a plot and a table. Both are
produced by an idl program that is called by this script. 

This script adds value to the idl program by validating the input,
selecting the appropriate data file for the ra and dec, converting the
idl program's plot to a gif, and embedding the results in an html page

=head1 INSTALLATION

The script stores its files in several directories, for security and
ease of use. First create a directory, to contain these scripts
underneath the cgi-bin directory and copy the contents of this
directory there. Then untar the data files into a directory that is
accessible from the machine the web server is running on. Create an
output directory in the html directory tree. Make it writabel by all
(chmod 777). Then update the configuration parameters listed below.

=head1 CONFIGURATION

The script has a number of parameters to be configured for the
script's proper operation.

=over 4

=item datafile_dir

The directory containing the data files used by this script. It should
be readable, but not writable, by the process running this script.

=item datafile_pattern

Used to construct the filename containing the twogyro data. it
contains perl variables ($name) representing the rounded ra and dec to
indicate where they are located in the filename.

=item idl_command

The full path name of the idl interpreter

=item idl_library

The directory containing the library of idl procedures

=item idl_script

The name of the idl procedure invoked by this program. It should not
have the .pro extension.

=item keep_days

The number of days output plots are retained before being deleted.

=item output_dir

The directory that containing the output files. It must be accessible
to the web server, that is, be located in a subdirectory of the top
html directory. It must also be writable by the process running the
webserver.

=item output_image

The template used to construct a random image name.

=item plot_title

The title of the plot. Can contain Perl variables $ra, $dec, and $date.

=item script_dir

The directory containing this script, the idl programs, and the html
templates.  It should be readable, but not writable, by the process
running this script.

=item form_url

The url of the page containing the form that invokes this script.

=item output_url

The url of the directory containing the out put images. The output
image name will be appended to this in the output html.

=item script_url

The url used to invoke this script.

=item full_template

The name of the template used to produce the output html page. It
contains placeholder variables of the form $(name).

=item output_template

=item work_dir

The directory containing the temporary files produced by this
script. It must be writable by the process running the webserver.

=item minimum_date

The earliest date stored in the data files. Used for input validation.

=item maximum_date

The latest date stored in the input files. Used for input validation.

=back

=cut

use strict;

use CGI;
use FileHandle;
use File::Copy;
use File::Basename;
use Image::Magick;

#----------------------------------------------------------------------
# Configuration variables

my %configuration = (
		     datafile_dir => '/opt/www/cgi-bin/TwoGyroWindowData',
		     datafile_pattern => '2gyro-ver-$ra-$dec.*',
		     idl_command => '/usr/local/rsi/idl/bin/idl',
		     idl_library => '/usr/local/rsi/idl/lib',
		     idl_script => 'vis_orient_v4',
		     keep_days => 0.5,
		     output_dir => '/var/html/observing/data',
		     output_image => 'tgy*.gif',
		     plot_title => 'RA = $ra, Dec = $dec',
		     script_dir => '/opt/www/cgi-bin',
		     form_url => 'http://www.stsci.edu/hst/HST_overview/TwoGyroMode/AllSkyWindow',
		     output_url => '/observing/data',
		     full_template => 'gyro_full_v4.pp',
		     output_template => 'gyro_output.pp',
		     work_dir => '/tmp',
		     minimum_date => '01 Jul 2006',
		     maximum_date => '31 Dec 2007',
		     );

#----------------------------------------------------------------------
# Main procedure
#----------------------------------------------------------------------

# Hacker prophylactic

$|=1;
umask (002);
$ENV{PATH}='/usr/bin:/opt/gnu/bin:/usr/local/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

# Get task parameters from cgi interface or command line

my $query = (@ARGV ? CGI->new (join ('&', @ARGV)) : CGI->new ());

# Construct urls from script's url

my $script = $ENV{SCRIPT_URI};
my ($script_base) = $script =~ m{^((?:http://)?[^/]*)};
$configuration{script_url} = $script;
$configuration{output_url} = "$script_base$configuration{output_url}";

# Create and bless the hash

my $twogyro = TwoGyro->new (query => $query, %configuration);
			    
# Set up error handler

$SIG{__DIE__} = sub {$twogyro->error (@_)};

# Clean up after ourselves

$twogyro->free_files;

if ($twogyro->validate) {
    # Calculate results
    $twogyro->calculate;

    # Display a web page back to the user
    $twogyro->show;

} else {
    # Redirect back to the original form in error case
    $twogyro->redirect;
}



#------------------------------------------------------------
package TwoGyro;
#------------------------------------------------------------

sub new {
    my ($pkg, %args) = @_;

    return bless (\%args, $pkg);
}

#------------------------------------------------------------
# 

sub calculate {
    my ($self) = @_;

    # Get idl script arguments

    my $ra = $self->get_rounded_ra;
    my $dec = $self->get_rounded_dec;
    my $date = $self->get_date;

    # Cry and go home if there are any problems

    $self->error if exists $self->{dict}{error};

    # Get input data file

    my $file = $self->lastfile ($ra, $dec);
    my ($ext) = $file =~ /\.([^\.]*)$/;

    my $title = $self->{plot_title};
    $title =~ s/(\$\w+)/$1/gee;

    # Create directory to hold input and output of idl script

    my $temp_dir = TwoGyro->mktemp ($self->{work_dir} . "/*/");
    $self->copy_temp ($temp_dir, $file);

    chdir ($temp_dir) or $self->error ("Couldn't cd to $temp_dir");

    # Run the idl script

    my $log = $self->call_idl ($ra, $dec, $date, $title, $ext);

    # Generate the html images and code

    $self->{dict}{output} = $self->create_output ($log);

    # Delete temporary files

    chdir ($self->{work_dir});
    $self->rmtemp ($temp_dir);
}

#------------------------------------------------------------
# Build the command string to call an idl procedure

sub call_idl {
    my ($self, @args) = @_;

    my $script = TwoGyro->mktemp ('*.pro');

    my $fd = FileHandle->new (">$script");

    @args = map ("'$_'", @args);
    my $cmd = join (',', $self->{idl_script}, @args);

    print $fd "$cmd\n";
    print $fd "exit\n";

    $fd->close;
 
    $ENV{IDL_STARTUP} = $script;
    $ENV{IDL_PATH} = join (':', $self->{script_dir}, $self->{idl_library});

    my $idl = $self->{idl_command};
    my $log = `$idl 2>&1`;
    $self->error ("$log\nExecution error") if $?;

    return $log;
}

#------------------------------------------------------------
# Copy files from datafile directory to temporary directory

sub copy_temp {
    my ($self, $temp_dir, @file) = @_;

    mkdir ($temp_dir, 0777);
    chmod (0777, $temp_dir);
    foreach my $file (@file) {
	my $in = $self->{datafile_dir} . '/' . $file;
	my $out = $temp_dir  . '/' . $file;

	File::Copy::copy ($in, $out) 
	  or $self->error ("Couldn't copy $file to $temp_dir");
    }
}

#----------------------------------------------------------------------
# Create output content

sub create_output {
    my ($self, $log) = @_;

    my @plot = $self->safe_glob ('*.ps');
    my @text = $self->safe_glob ('*.txt');

    if (! @plot) {
	my $error;
	if (@text) {
	    foreach my $text (@text) {
		$error .= TwoGyro->slurp ($text);
	    }
	}

	$error = $log if $error !~ /\s/;
	$self->error ($error);
    }


    my $output;
    my $pattern = $self->{output_dir} . '/' . $self->{output_image};

    foreach my $plot (@plot) {

	my $img = Image::Magick->new();
	my $rc = $img->Read ($plot);
	$self->error ($rc) if $rc;

	$rc = $img->Rotate (degrees => 270);
	$self->error ($rc) if $rc;

	my $image = TwoGyro->mktemp ($pattern);
	$rc = $img->Write ($image);
	$self->error ($rc) if $rc;

	my $url = $self->{output_url} . '/' . 
	  File::Basename::basename ($image);

	my $text = TwoGyro->slurp (shift @text);
	my $hash = {url => $url, text => $text};

	foreach my $atrib (qw(width height)) {
	    $hash->{$atrib} = $img->Get ($atrib);
	}
	
	$output .= $self->interpolate ($self->{output_template}, $hash);
    }

    return $output;
}

#------------------------------------------------------------
# Send an error message as an html form

sub error {
    my ($self, @arg) = @_;

    $self->{dict}{error} .= join ("\n", @arg);
    $self->redirect;
}

#------------------------------------------------------------
# Free temporary files

sub free_files {
    my ($self) = @_;

    my $pattern = $self->{output_dir} . '/' . $self->{output_image};
    my @file = $self->safe_glob ($pattern);

    # Find all files not modified recently and delete them

    foreach my $file (@file) {
	$file = $self->untaint_filename ($self->{output_dir} . '/' . $file);
	unlink $file if -M $file > $self->{keep_days};
    }
}

#------------------------------------------------------------
# Retrieve date from input form data, check it as a side effect

sub get_date {
    my ($self) = @_;

    my %month = (Jan => 31, Feb => 28, Mar => 31, Apr => 30, 
		 May => 31, Jun => 30, Jul => 31, Aug => 31,
		 Sep => 30, Oct => 31, Nov => 30, Dec => 31);

    my $name = ucfirst lc substr ($self->{dict}{month}, 0, 3);

    my $length = $month{$name};
    $length += 1 if ($self->{dict}{year} % 4) == 0 && $name eq 'Feb';

    $self->{dict}{error} .= "Invalid format for month\n" unless $length;

    $self->{dict}{error} .= "Day out of range\n" 
      if $self->{dict}{day} > $length;
    
    $self->y2k;

    my $date = sprintf ("%02d %s %d", $self->{dict}{day}, 
			$name, $self->{dict}{year});

    my $serial = TwoGyro->serial ($date);

    $self->{dict}{error} .= "Requested date not in nominal range for the cycle - no data available.\n" if
      $serial < TwoGyro->serial ($self->{minimum_date}) or
      $serial > TwoGyro->serial ($self->{maximum_date});

    return $date;
}

#------------------------------------------------------------
# Compute declination rounded to nearest five degrees

sub get_rounded_dec {
    my ($self) = @_;

    my ($d, $m, $s) = split (/:/, $self->{dict}{dec});
    $m = 0 unless defined $m;
    $s = 0 unless defined $s;

    $self->{dict}{error} .= "Declination out of range\n" 
      if $m >= 60 || $s >= 60;

    my $degrees =  ((abs($d) * 60 + $m) * 60 + $s) / 3600.;
    $self->{dict}{error} .= "Declination out of range\n" 
      if $degrees < 0 || $degrees > 90;

    $degrees = 5.0 * int (($degrees + 2.5) / 5.0);
    $degrees = 85. if $degrees > 85.;

    $degrees = - $degrees if $degrees && $d =~ /^-/;
    return $degrees;
}

#------------------------------------------------------------
# Generate a list of html options for a list of values

sub generate_options {
    my ($self) = @_;

    my @days = 1 .. 31;
    my @years = 2006 .. 2007;
    my @months = qw (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

    my %list = (
		'day' => \@days,
		'month' =>\@months,
		'year' => \@years,
		);

    foreach my $name (keys %list) {
	my $option;
	my $list = $list{$name};
	my $value = $self->{dict}{$name};

	foreach my $item (@$list) {
	    my $selected = $item eq $value ? 'selected' : '';
	    $option .= "<option value=\"$item\" $selected>$item</option>\n"
	}

	$self->{dict}{"${name}option"} = $option; 
    }
}

#------------------------------------------------------------
# Compute right ascension rounded to nearest five degrees

sub get_rounded_ra {
    my ($self) = @_;

    my ($h, $m, $s) = split (/:/, $self->{dict}{ra});
    $m = 0 unless defined $m;
    $s = 0 unless defined $s;

    $self->{dict}{error} .= "Right ascension out of range\n" 
      if $m >= 60 || $s >= 60;

    my $hours = ((abs($h) * 60 + $m) * 60 + $s) / 3600;
    my $degrees = 15. * $hours;

    $self->{dict}{error} .= "Right ascension out of range\n" 
      if ($h =~ /^-/) || $degrees < 0 || $degrees > 360.;

    $degrees =  5.0 * int (($degrees + 2.5) / 5.0);
    $degrees = 0. if $degrees >= 360.;

    return $degrees;
}

#----------------------------------------------------------------------
# Interpolate dictionary values in a template

sub interpolate {
    my ($self, $file, $dict) = @_;

    my $template = $self->{script_dir} . '/' . $file;
    my $text = TwoGyro->slurp ($template);

    $text =~ s/\$\(([^\)]*)\)/$dict->{$1}/ge;
    return $text;
}

#----------------------------------------------------------------------
# Test a variable to see if it is tainted

sub is_tainted {
    my ($pkg, $var, $name) = @_;

    my $nada = substr ($var, 0, 0);

    local $@;
    eval { eval "# $nada" };

    die "$name is tainted" if length ($@) != 0;
}

#----------------------------------------------------------------------
# Glob files and return the last in alphabetical order. Taint safe.

sub lastfile {
    my ($self, $ra, $dec) = @_;

    my %patmap = (
		    '*' => '.*',
		    '?' => '.',
		    '[' => '[',
		    ']' => ']',
		  );

    my $glob = $self->{datafile_dir} . '/' . $self->{datafile_pattern};
    $glob =~ s/(\$\w+)/$1/gee;

    my @file = $self->safe_glob ($glob);

    my $file = $self->untaint_filename (pop (@file));
    $self->error ("No file found at RA=$ra Dec=$dec") unless $file;

    return $file;
}

#----------------------------------------------------------------------
# Create a temporary file name that does not colide with a current file

sub mktemp {
    my ($pkg, $pattern) = @_;

    my ($id, $file);
    do {
	$id = '';
	$id .= sprintf ("%04x", int (rand (65536))) for (1 .. 4);

	($file = $pattern) =~ s/\*/$id/;
    } while -e $file;

    return $file;
}

#------------------------------------------------------------
# Redirect user to another web page

sub redirect {
    my ($self) = @_;

    # Generate the entire page if it contains output

    $self->show if $self->{dict}{output} || length ($self->{dict}{error}) > 80;

    # Calculate parameter list

    my $param;
    for my $name (qw (ra dec day month year error)) {
	next unless exists $self->{dict}{$name};

	my $value = $self->{dict}{$name};
	$value =~ s/[&\+]/sprintf ('%%%02x', ord($1))/ge;
	$value =~ tr/ \n/+/;
	
	if ($param) {
	    $param .= '&';
	} else {
	    $param = '?';
	}

	$param .= "$name=$value";
    }

    my $url = $self->{form_url} . $param;
    print "Location: $url\n\n";
    exit (0);
}

#----------------------------------------------------------------------
# Remove a temporary file previously created

sub rmtemp {
    my ($self, $file) = @_;

    if (-d $file) {
	system ('/usr/bin/rm', '-rf', $file);

    } else {
	unlink ($file);
    }

    $self->error ("Could not delete temp file: $file") if -e $file;
}

#----------------------------------------------------------------------
# Taint safe replacement for glob

sub safe_glob {
    my ($self, $glob) = @_;

    my %patmap = (
		    '*' => '.*',
		    '?' => '.',
		    '[' => '[',
		    ']' => ']',
		  );

    my @dir = split (/\//, $glob);
    my $pattern = pop (@dir);
    my $dir = join ('/', @dir) || '.';

    $pattern =~ s{(.)} {$patmap{$1} || "\Q$1"}ge;
    $pattern = '^' . $pattern . '$';

    $self->error ("Directory not found: $dir") unless -e $dir;

    opendir (FH, $dir);
    my @file = reverse sort grep /$pattern/, readdir (FH);
    closedir (FH);

    return @file;
}

#----------------------------------------------------------------------
# Serial date computation

sub serial {
    my ($pkg, $date) = @_;

    my %month = (Jan => 1,  Feb => 2,  Mar => 3,  Apr => 4, 
		 May => 5,  Jun => 6,  Jul => 7,  Aug => 8, 
		 Sep => 9,  Oct => 10, Nov => 11, Dec => 12);

    my ($d, $m, $y) = split (' ', $date);
    $m = $month{$m};

    $y = $y - 1900;
    my $serial = int (365.25 * $y) + int (30.55 * ($m + 2)) + $d - 91;

    if ($m > 2) {
	if ($y && $y % 4 == 0) {
	    $serial = $serial - 1;
	} else {
	    $serial = $serial - 2;
	}
    }

    return $serial;
}


#----------------------------------------------------------------------
# Run the output through a preprocessor

sub show {
    my ($self) = @_;

    $self->generate_options;

    print "Content-type: text/html\n\n";
    print $self->interpolate ($self->{full_template},
			      $self->{dict});

    exit (0);
}

#----------------------------------------------------------------------
# Read a file into a string

sub slurp {
    my ($pkg, $input) = @_;

    local $/;

    my $in = FileHandle->new ($input);
    return '' unless defined $in;

    my $text = <$in>;
    $in->close;

    return $text;
}

#------------------------------------------------------------
# Untaint a file name that was read from a directoy

sub untaint_filename {
    my ($self, $file) = @_;

    if ($file =~ /^([\w\.\-\_\/]*)$/) {
	$file = $1;
    } else {
	$self->error ("Illegal character in filename: $file");
    }

    return $file;
}

#------------------------------------------------------------
# Check input for correct format and untaint it

sub validate {
    my ($self) = @_;

    my %pattern = (
		   ra => qr/^\s*([\+\-]?[\d:]+\.?\d*)\s*$/,
		   dec => qr/^\s*([\+\-]?[\d:]+\.?\d*)\s*$/,
		   day => qr/^\s*(\d\d*)\s*$/,
		   month => qr/^\s*(\w\w\w)\s*$/,
		   year => qr/^\s*(\d{2,4})\s*$/,
		  );

    my $data = 0;
    foreach my $name (keys %pattern) {
	if (exists $self->{query}{$name}) {
	    my $value = $self->{query}{$name}[0];

	    if ($value =~ /$pattern{$name}/) {
		$self->{dict}{$name} = $1;
		$data = 1;

	    } elsif ($value !~ /\S/) {
		$self->{dict}{error} .= "Missing value for $name\n";

	    } else {
		$self->{dict}{error} .= "Invalid format for $name\n";
		$data = 1;
	    }

	} else {
	    $self->{dict}{error} .= "Missing value for $name\n";
	}
    }

    $self->{dict}{script_url} = $self->{script_url};

    delete $self->{dict}{error} unless $data;
    return $data && ! exists $self->{dict}{error};
}

#----------------------------------------------------------------------
# Two digit to four digit year between 1970 and 2069

sub y2k {
    my ($self) = shift;

    if ($self->{dict}{year} < 70) {
	$self->{dict}{year} += 2000;

    } elsif ($self->{dict}{year} < 100) {
	$self->{dict}{year} += 1900;
    }
}
