# -*- perl -*- 
#
# DO NOT MOVE THE FIRST LINE
# It identifies the rest of the file as PERL for EMACS autoformatting
# put perl options at the end of that line, e.g., -p
#
# 
# -------------------------------------------------------------------
#                                   X-BONE
#
#                          http://www.isi.edu/xbone
#                USC Information Sciences Institute (USC/ISI)
#                   Marina del Rey, California 90292, USA
#                          Copyright (c) 1998-2005
# 
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute.  The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
# 
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
#  $RCSfile: XB_XML_Interface.pm,v $
#
# $Revision: 1.27 $
#   $Author: pingali $
#     $Date: 2005/04/06 21:53:21 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert

package XB_XML_Interface;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(OverlayManagerInterface);

use strict;
use sigtrap;

use lib qw(../lib);

use Text::ParseWords;
use Getopt::Long;
use AppConfig; 
use CGI qw(:standard :html3);
use CGI::Carp qw(fatalsToBrowser);
#use XB_Common;
use Net::IP;
use Net::Netmask;
use Net::hostent;
use IO::Socket;
use IO::Socket::SSL;


use Socket6;
use IO::Socket::SSLv6; 

use FileHandle;
use POSIX qw(:errno_h);

use XB_Params;

use Data::Dumper;		# Needed only for debugging

use XB_XML_GUI; 


############################################################
#
# read the configuration file 
#
############################################################
sub init () { 

  %XB_Params::node_opts = 
    (
     # basic configuration options
     "gui_conf"           => $XB_Params::gui_conf,
     "hostname"           => `hostname`,
     "ctl_addr"           => $XB_Params::ctl_addr,
     "ctl_addr6"          => $XB_Params::ctl_addr6,
     "ipproto"            => $XB_Params::ipproto,
     "node_cert"          => $XB_Params::node_cert,
     "node_key"           => $XB_Params::node_key,
     "ca_cert"            => $XB_Params::ca_cert,
     "ca_path"            => $XB_Params::ca_path,
     "xbone_net" 	  => $XB_Params::XBONE_NET,
     "timeout"            => $XB_Params::NET_TIMEOUT,
     "xbone_api_port"	  => $XB_Params::xbone_api_port
    );
  my @opts_spec = 
    (
     "gui_conf|gc=s",                    # this is there more for completeness
     "hostname|h=s",                     # hostname
     "ctl_addr|caddr=s",                 # addr for control connection  IPv4
     "ctl_addr6|caddr6=s",               # addr for control connection  IPv6
     "ipproto|ip=s",
     # X.509 certificate & key info
     "node_cert|cert=s",
     "node_key|key=s",
     "ca_cert|ca=s",
     "ca_path|cp=s",
     "xbone_net|xn=s",
     "timeout|t=s",
     "xbone_api_port|api=i",
    );
  
  my $file_opts = AppConfig->new(@opts_spec);
  $file_opts->file($XB_Params::node_opts{gui_conf}); 
  # this might die #

  #=> merge command line options & conf file options
  for my $n (keys %XB_Params::node_opts){
    $XB_Params::node_opts{$n} = 
      (defined $file_opts->get($n)) ?
      $file_opts->get($n) : $XB_Params::node_opts{$n};
  }

  if ((not defined ($XB_Params::node_opts{ctl_addr}) ||  
       $XB_Params::node_opts{ctl_addr} eq "") && 
      $XB_Params::node_opts{ipproto} =~ /(ipv4|both)/){ 
     $XB_Params::node_opts{ctl_addr} = 
	     getaddr($XB_Params::node_opts{hostname}, 'ipv4'); 
  }

  if ((not defined ($XB_Params::node_opts{ctl_addr6}) ||  
       $XB_Params::node_opts{ctl_addr6} eq "") && 
      $XB_Params::node_opts{ipproto} =~ /(ipv6|both)/){ 
     $XB_Params::node_opts{ctl_addr6} = 
	     getaddr($XB_Params::node_opts{hostname}, 'ipv6'); 
  }
    
}


############################################################
#
# retrieve the information stored in the environment variables
# in a convenient form. 
#
############################################################


sub user_info() { 

  my ($email, $name, $org, $loc) = ("")x4;

  if (defined $ENV{SSL_CLIENT_EMAIL} and $ENV{SSL_CLIENT_EMAIL} ne ""){
     $email = $ENV{SSL_CLIENT_EMAIL};
  } elsif (defined $ENV{SSL_CLIENT_S_DN_Email} and
              $ENV{SSL_CLIENT_S_DN_Email}  ne ""){
     $email = $ENV{SSL_CLIENT_S_DN_Email};
  } elsif (defined $ENV{SSL_CLIENT_S_DN_EMAILADDRESS} and
              $ENV{SSL_CLIENT_S_DN_EMAILADDRESS}  ne ""){
     $email = $ENV{SSL_CLIENT_S_DN_EMAILADDRESS};
  } else {
    $email = "";
  }

  if (defined $ENV{SSL_CLIENT_CN} and $ENV{SSL_CLIENT_CN}  ne ""){
     $name = $ENV{SSL_CLIENT_CN};
  } elsif (defined $ENV{SSL_CLIENT_S_DN_CN} and 
	   $ENV{SSL_CLIENT_S_DN_CN}  ne ""){
     $name = $ENV{SSL_CLIENT_S_DN_CN};
  } else { 
    $name = ""; 
  }

  if (defined $ENV{SSL_CLIENT_O} and $ENV{SSL_CLIENT_O}  ne ""){
    $org = $ENV{SSL_CLIENT_O} .
      ($ENV{SSL_CLIENT_OU} ? ", $ENV{SSL_CLIENT_OU}" : "");
  } elsif (defined $ENV{SSL_CLIENT_S_DN_O} and 
	   $ENV{SSL_CLIENT_S_DN_O}  ne ""){
    $org = $ENV{SSL_CLIENT_S_DN_O} .
      ($ENV{SSL_CLIENT_S_DN_OU} ? ", $ENV{SSL_CLIENT_S_DN_OU}" : "");
  } else {
    $org = ""; 
  }

  if (defined $ENV{SSL_CLIENT_L} and $ENV{SSL_CLIENT_L}  ne ""){
    $loc = $ENV{SSL_CLIENT_L};
  } elsif (defined $ENV{SSL_CLIENT_S_DN_L} and
	   $ENV{SSL_CLIENT_S_DN_L}  ne ""){
    $loc = $ENV{SSL_CLIENT_S_DN_L};
  } else {
    $loc = "";
  }

  my %user = ( User         => "$name <" .
	                       a({-href => "mailto:$email"},
				 $email) . ">",
	       Organization => $org,
	       Location     => $loc,
	       Email        => $email,
	       Name         => $name
	     );
  
  return %user; 
}

#############################################################
# Copied from programs/modules/XB_Common.pm 
# 
# Description:
#     Return an array of addresses for a given hostname of specified type.
# Arguments:
#     $hostname hostname to lookup
#     $ipproto  ipv4 or ipv6
# Returns:
#     \@addrs   IP addresses of the given hostnames
# Exception:
#     "getaddrinfo" on failure, nothing to cleanup by caller
#############################################################
sub getaddr($$){
  my ($hostname, $ipproto) = @_;
  my $procname = "getaddr";
  my @addrs;
  eval{
    unless($hostname =~ /\S+/){ die "hostname"; }
    unless($ipproto =~ /(ipv6|ipv4)/){ die "ipproto"; }

    my ($family, $socktype, $proto, $saddr, $canonname);
    my @res; 

    if($ipproto eq 'ipv4'){
      @res = getaddrinfo($hostname, 
			 'daytime', # dummy service 
			 AF_INET);
      unless(scalar(@res) >=  5){ die "getaddrinfo"; };
    } else {
      @res = getaddrinfo($hostname, 
			 'daytime', # dummy service 
			 AF_INET6);
      unless(scalar(@res) >= 5){ die "getaddrinfo"; };	
    } # give getaddrinfo call

    while (scalar(@res) >= 5) {
	$family = -1; # for safety 
	($family, $socktype, $proto, $saddr, $canonname, @res) 
	    = @res;
	my ($addr, $dummyport) = 
	    getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV);
	
	push @addrs, $addr; 	      
    }
    unless(@addrs > 0){  die "noaddr"; }
  }; #eval 
  return \@addrs unless $@;
  die "$procname";
}


################################################################
# 
# Contact the OM with the message passed as argument to the
# funtion. 
# 
################################################################

sub OverlayManagerInterface($$) {
  my $peer = shift;
  my $str = shift;
  my $buf = "";
  my $return_string = "";
  my $routeraddr;

  my %user = user_info(); 
  my %cred = ( 
	      'user_name' => $user{Name}, 
	      'user_email' => $user{Email}, 
	      'auth_type' => 'x509' 
	     ); 
	      
  # Open a connection to the overlay manager, send it the prepared
  # string, and get the response string back

  my $tcph; 
  my $msg = ""; 
  foreach my $location (
			"$XB_Params::node_opts{node_cert}",
			"$XB_Params::node_opts{node_key}",
			"$XB_Params::node_opts{ca_cert}", 
			"$XB_Params::node_opts{ca_path}"){

    unless (-e "$location" and -r "$location")
      {
	$msg .= "\n       $location,"; 
      };
  }

  if ($msg ne "") {
    my $hostname = `hostname`; 
    chomp($hostname);
    $_ = XB_XML_GUI::XB_build_api_errmsg 
      ( \%cred, "The GUI backend on host $hostname is either missing or unable to read the ".
	"the following files necessary for ".
	"communicating with the Overlay Manager: " . $msg . 
	" Please update /usr/local/etc/xbone/xbone-gui.conf with the correct locations.");
    return ($$_);
  }; 
  
  my $n = Net::IP->new($peer); 
  if (defined $n){
    $_ = XB_XML_GUI::XB_build_api_errmsg 
      (\%cred, 
       "Please use hostname instead of IP address"); 
    return ($$_);
  } 

  # allow the user to specify a name and a port
  my ($peerhost, $peerport);   
  if ($peer =~ /:/){
    ($peerhost, $peerport) = split(':', $peer); 
  } else {
    ($peerhost, $peerport) = ($peer, $XB_Params::node_opts{xbone_api_port}); 
  }
  
  my $errmsg = "";
  eval {

    $tcph = IO::Socket::SSL->new(
				PeerAddr => $peerhost, 
				PeerPort => $peerport, 
				LocalAddr => $XB_Params::node_opts{ctl_addr},
				Proto => 'tcp',	
				Reuse => 1,
				SSL_use_cert    => 1,
				SSL_verify_mode => 0x03,
				SSL_cert_file   => $XB_Params::node_opts{node_cert},
				SSL_key_file   =>  $XB_Params::node_opts{node_key},
				SSL_ca_file     => $XB_Params::node_opts{ca_cert}, 
				SSL_ca_path     => $XB_Params::node_opts{ca_path},
			       );

  }; 
  if ($@) {
    $errmsg = $@; 
  }
  
  if (not defined $tcph){
    eval { 
	
	my $addrs = getaddr($peerhost, 'ipv6'); 
	foreach my $dest (@{$addrs}){
	  $tcph = IO::Socket::SSLv6->new(
				       PeerAddr => $dest, 
				       PeerPort => $peerport, 
				       LocalAddr => $XB_Params::node_opts{ctl_addr6},
				       Proto => 'tcp',	
				       Reuse => 1,
				       SSL_use_cert    => 1,
				       SSL_verify_mode => 0x03,
				       SSL_cert_file   => $XB_Params::node_opts{node_cert},
				       SSL_key_file    => $XB_Params::node_opts{node_key},
				       SSL_ca_file     => $XB_Params::node_opts{ca_cert}, 
				       SSL_ca_path     => $XB_Params::node_opts{ca_path}
				      );
	  last if $tcph;
      } # foreach destination ip address 
    }; # eval 
    $errmsg .= $@;
  }; 


  unless ($tcph)
    { 
      $_ = XB_XML_GUI::XB_build_api_errmsg ( \%cred, 
					"Cannot open socket to $peerhost:$peerport. $!.  " .
					"Suspect Overlay Manager is down or does not " .
					"support the IP version specified in GUI configuration file. ".
					"Do check whether both the webserver host and the manager's".
					" host support the ip version specified in the configuration file");
      return ($$_);
    };
  print $tcph "$str\n XBoneEOC \n";

  # Select to wait until the socket becomes ready to read
  my $start_time = time;
  my $total_time = $XB_Params::node_opts{timeout}; 

  my ($inputflags, $errorflags, $iflg, $eflg) = ("") x 4;
  vec ($inputflags, $tcph->fileno, 1) = 1;
  $errorflags = $inputflags;

  while (1)
    {

      my $events = 
	select($iflg = $inputflags, undef, $eflg = $errorflags, $total_time);

      # When something (either the socket or the timer goes off
      if (vec ($iflg, $tcph->fileno, 1))
	{
	  # Make the read call non-blocking so we can avoid getting blocked
	  # if the other end crashes
	  fcntl($tcph, F_SETFL, O_NDELAY);
	  my ($buf, $byte_read);

	  # do sysread until it returns either 0 (EOF) or undef (error)
	  if(defined($byte_read = sysread($tcph, $buf, 1000)))
	    {
	      unless($byte_read == 0){ $return_string .= $buf; }
	    }

	  if (defined $return_string and $return_string =~ /\bXboneEOC\b/)
	  {  last;  }

	  # check for error condition of sysread
	  if (not defined $byte_read)
	    {
	      if (defined $!)
		{
		  if ($! == EWOULDBLOCK)
		    {
		      undef $!;	# clean up error flag for the next round
		      next;	# since we loop back to select, no need to sleep
		    }
		  elsif ($! != 0)
		    {
		      # some other error
		      my $errno = $! + 0; # Force numeric context
		      $_ = XB_XML_GUI::XB_build_api_errmsg (\%cred, 
			      "$errno: $!.  " .
			      "This is wierd.  Don't expect anything except " .
			      "EWOULDBLOCK here.");
		      $return_string = $$_;
		      last;
		    }
		  else
		    { # $!=0 => EOF
		      last;
		    }  
		} else
		  { # undefined $! => EOF
		    last;
		  }  
	    }
	  elsif ($byte_read == 0)
	    { # byte_read = 0 => EOF
	      last;
	    }

	  if(time > $start_time + $total_time)
	    {
	      $_ = XB_XML_GUI::XB_build_api_errmsg (\%cred, 
				"Non-blocking read from Overlay " .
		                "Manager timed out.".
				"Consider increasing the timeout setting".
				"in the X-Bone GUI configuration file (typically ".
				"xbone-gui.conf)");
	      return ($$_);
	    }
	}
      elsif (vec ($eflg, $tcph->fileno, 1))
	{
	  $_ = XB_XML_GUI::XB_build_api_errmsg (\%cred, 
					    "IO error on TCP socket. $!.");
	  return ($$_);
	}
      else
	{
	  # Must be due to time limit.
	  $_ = XB_XML_GUI::XB_build_api_errmsg (\%cred, 
				 "Select to overlay manager timed out. ". 
				 "Consider increasing the timeout setting". 
				 "in the X-Bone GUI configuration file (typically ".
				 "xbone-gui.conf)");
	  return ($$_);
	}
    }

  $tcph->close();
  if ($return_string eq "")
    {
      $_ = XB_XML_GUI::XB_build_api_errmsg (\%cred, 
                              "Null message from Overlay Manager. There are a couple" .
			      " of possibilities. (1) The operation (create/discover)".
			      " timed out. (2) The overlay manager might have crashed\n"); 
      return ($$_);
    }

  return ($return_string);
}


sub show_success ($$$) {
 my ($success, $extra, $url) = @_;

 my $host = `uname -n`; 
 chomp($host); 

 if (defined $extra) { $success .= " " . $extra; }

 my $msg = "content-type: text/xml\n\n";
 #my $msg = "content-type: text/plain\n\n";
 $msg .= "<?xml version=\"1.0\"?>\n";
 $msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/error-xsl.xml\"?>\n";
 $msg .= "<success>\n";
 $msg .= "   <source>$url</source>\n";
 $msg .= "   <message>$success</message>\n";
 $msg .= "   <manager>" . param("manager") . "</manager>\n";
 $msg .= "   <host>$host</host>\n";
 $msg .= "</success>\n";
 print $msg;
 exit;
}

sub show_error ($$$){
 my ($error, $extra, $url) = @_; 

 my $host = `uname -n`; 
 chomp($host); 

 if (defined $extra) { $error .= " " . $extra; }

 $error =~ s/\</\&lt\;/sg;
 $error =~ s/\>/\&gt\;/sg;

 my $msg = "content-type: text/xml\n\n"; 
 $msg .= "<?xml version=\"1.0\"?>\n";
 $msg .= "<?xml-stylesheet type=\"text/xsl\" href=\"/xml/error-xsl.xml\"?>\n";
 $msg .= "<error>\n";
 $msg .= "   <source>$url</source>\n";
 $msg .= "   <message>$error</message>\n";
 $msg .= "   <manager>" . param("manager") . "</manager>\n";
 $msg .= "   <host>$host</host>\n";
 $msg .= "</error>\n";
 print $msg; 
 exit; 
}



1;