### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines 
# identifies the rest of the file as PERL for EMACS autoformatting. 
# See end of copyright for more information.
#
# 
# -------------------------------------------------------------------
#                                   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.
#
# -------------------------------------------------------------------
# 

##################################################
#
#
# XBone API utilities used both by the OM and the GUI
#
# Principal author: Gregory Finn
#
##################################################

package XB_XOL;


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


use strict;

#use Data::Dumper;           # Used for debugging, comment out for release.

#use XB_Log;                 # Problematic.  Both GUI and OM use this package.

use XB_Params;





#######################################################################
#
# XB_qstring ( string )
#
# Returns a properly quoted version of its string argument.  If string
# contains whitespace or single quotes, it is returned double quoted.
#######################################################################

sub XB_qstring ($)
  {
    my ($arg) = @_;

    $arg =~ s/^\s+//;		# Eliminate leading and trailing whitespace
    $arg =~ s/\s+$//;

    if ($arg =~ /^".+"$/)
      {  return ($arg);  }
   elsif ($arg =~ /^'.+'$/)
      {  return ($arg);  }
    elsif ($arg =~ /\s+/)
      {  return ("\'$arg\'");  };

    return ($arg);
  }





#######################################################################
#
# XB_build_criterions ( key, value, key, value, ... )
#
# Accepts as an argument a list (key value key value ...) where
# each key/value pair is a CRITERION.  For each pair the
# syntactically correct CRITERION string "(key value)" is created.
#
# Normally a reference to the string containing all the CRITERION
# strings is returned.  A value of undef is returned if the argument
# list is not balanced, that is, some key is missing its corresponding
# value.
#######################################################################

sub XB_build_criterions (@)
  {
    my ($key, $value, $string);

    if (scalar (@_) % 2) { return (undef); };

    $string = "";
    while (1)
      {
	$key = shift;
	$value = shift;

	if (!defined ($key))
	  { return (\$string); };

	$string .= " (" . XB_qstring ($key) . "  " .
	           XB_qstring ($value) . ") ";
      }
  }





######################################################################
#
# sub XB_check_criterion_values ( href keylist ... )
#
# href references a hash that contains CRITERION key/value pairs.
# keylist is a series of key names.  Associated with each key name
# is a syntax requirement on its value.  Each key passed in keylist
# is used to access that key/value pair in the href hash.  The values
# are checked against their corresponding requirements.
#
# A non-zero return is an explanatory error string.  A zero return
# implies that all key names in keylist had proper values.
######################################################################

sub XB_check_criterion_values ($@)
  {
    my ($href, $key, $value, $ix);

    $href = shift (@_);

    for ($ix = 0;  $ix < scalar (@_);  $ix++)
      {
	$key = $_[$ix];

	if (!exists ($href->{$key}))
	  {  next;  };

	if (!defined ($href->{$key}))
	  {  return ("Illegal undefined value for key: $key");  }

	$value = $href->{$key};

	if ( ($key eq 'dynamic_routing') ||
	     ($key eq 'two_phase' )
	   )
	  {
	    if ($value !~ /^yes|no$/i)
	      {  return ("A $key value is either: yes or no");  }
	    next;
	  };

	if ($key eq 'topology')
	  {
	    if ($value !~ /^ring|line|star$/i)
	      {  return ("A $key value is either: ring, line or star");  }
	    next;
	  };

	if ( ($key eq 'release') ||
	     ($key eq 'protocol')
	   )
	  {
	    if ($value !~ /^[0-9]+\.[A-Za-z0-9-]+$/)
	      {  return ("A $key number has the form \"number.alphanumeric\"");  }
	    next;
	  };

	if ( ($key eq 'timeout') ||
	     ($key eq 'node_count') ||
	     ($key eq 'max_tunnels') ||
	     ($key eq 'tunnel_count') ||
	     ($key eq 'max_overlays') ||
	     ($key eq 'max_interfaces') ||
	     ($key eq 'overlays') ||
	     ($key eq 'interfaces') ||
	     ($key eq 'search_radius')
	   )
	  {
	    if ($value !~ /^[0-9]+$/)
	      {  return ("An $key value is a non-negative integer"); }
	    next;
	  };

	if ($key eq 'status')
	  {
	    if ($value !~ /^in|out|up|down$/)
	      {  return ("A $key value is either: in or out");  }
	    next;
	  };

	if ($key eq 'auth_type')
	  {
	    if ($value !~ /^x509$/i)
	      {  return ("Only x509 $key is supported");  }
	    next;
	  };

	if ($key eq 'authentication')
	  {
	    my (@fields, $field);
	    $_ = $value;
	    @fields = split;
	    foreach $field (@fields)
	      {
		if ($field !~ /md5|sha1|none/i)
		  {
		    return
		      ("An $key value is either: md5, sha1 or none");
		  }
	      }
	    next;
	  };

	if ($key eq 'encryption')
	  {
	    my (@fields, $field);
	    $_ = $value;
	    @fields = split;
	    foreach $field (@fields)
	    {
	      if ($field !~ /des|3des|none/i)
		{
		  return ("An $key value is either: des, 3des or none");
		}
	    }
	    next;
	  };

	if ($key eq 'class')
	  {
	    if ($value !~ /^host|router$/i)
	      {  return ("A $key value is either: host or router");  }
	    next;
	  };

	if ($key eq 'creator_name')
	  {
	    if ($value !~ /^[A-Z. \'\-]+$/i)
              {  return ("The string $value is not a proper $key");  }
	    next;
	  };

	if ( ($key eq 'creator_email') ||
	     ($key eq 'user_id') )
	  {
            if ($value !~ /^[A-Z0-9_\.]+@[A-Z0-9-_\.]+$/i)
              { return ("The string $value is not a proper $key"); }
	    next;
	  };

	if ( ($key eq 'os') ||
	     ($key eq 'host_os') ||
	     ($key eq 'router_os') )
	  {
            my ($os, $found, $matchos);
	    my (@values);

	    @values = split /\|/, $value;      # String is "os0|os1|...|osn"
	    $found = 0;
            foreach $os (@XB_Params::ALLOWED_NODEOS)
              {
		foreach $matchos (@values)
		  {
		    if ($matchos =~ /^$os$/)  { $found = 1;  last; };
		  }
	      }

	    if (!$found)
	      { return
		  ("The OS $value is not a supported operating system");
	      }

	    next;
	  };

	if ( ($key eq 'ip_address') ||
	     ($key eq 'local_ip_addr') ||
	     ($key eq 'remote_ip_addr') )
	  {
	    if ($value =~ /\./)
	      {
		if (!XB_check_IPv4_syntax ($value))
		  {  return ("Incorrect IPv4 address string: $value ");  };
	      }
	    else
	      {
		if (!XB_check_IPv6_syntax ($value))
		  {  return ("Incorrect IPv6 address string: $value ");  };
	      };
	    next;
	  };

	if ($key eq 'overlay_name')
	  {
	    if ($value =~ /\s+/)
	      {  return ("Embedded whitespace not allowed in $key");  }
	    next;
	  };

	if ($key eq 'application')
	  {
	    next;
	  };

	if ($key eq 'error')
	  {
	    next;
	  };

	if ($key eq 'command')
	  {
	    next;
	  };
      };

    return (0);
  }





######################################################################
#
# sub XB_check_IPv4_syntax ( addr )
#
# Performs basic check on addr passed as an IPv4 numeric address.
# Returns either true or false.
######################################################################

sub XB_check_IPv4_syntax ($)
  {
    my ($addr) = @_;

    if ($addr =~ /^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/ )
      {
	return (1);
      };

    return (0);
  }





######################################################################
#
# sub XB_check_IPv6_syntax ( addr )
#
# Performs basic check on addr passed as an IPv6 numeric address.
# Returns true if the syntax is OK.  Otherwise, it returns false.
######################################################################

sub XB_check_IPv6_syntax ($)
  {
    my ($addr) = @_;  my (@fields, $ix);

    ############################
    # Break apart on colon chars
    # and eliminate empty fields
    ############################

    @fields = split /:/, $addr;
    $ix = 0;
    while (defined ($fields[$ix]))
      {
	if (!$fields[$ix])
	  {  splice @fields, $ix;  }
	$ix++;
      };

    #################################
    # Should now only have hex fields
    #################################

    $ix = scalar (@fields);

    if (($ix < 1) || ($ix > 8))   # Limit number of fields
      { return (0); };

    $ix = 0;
    while (defined ($fields[$ix]))
      {
	if ($fields[$ix] !~ /^[A-F0-9]{1,4}$/i)
	  { return (0); }
	$ix++;
      };

    return (1);
  }





######################################################################
#
# sub XB_build_api_errmsg ( command, error_message, auth_type, user_id )
#
# Builds a message with the indicated command and one criterion pair
# error/error_message.  The auth_type and user_id fields are optional.
# If they are not supplied, they will not be included in the message.
#
# A reference to the message string is returned.
######################################################################

sub XB_build_api_errmsg ($$;$$)
  {
    my ($command, $error_message, $auth_type, $user_id) = @_;
    my ($string, $cs_ref, @args);

    $string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
    $string .= "\t($command ";

    @args = ();
    push @args, 'error', $error_message;
    if (defined ($auth_type))  {  push @args, 'auth_type', $auth_type;  };
    if (defined ($user_id))  {  push @args, 'user_id', $user_id;  };

    print "ARGS: @args\n";

    $cs_ref = XB_XOL::XB_build_criterions ( @args );
    if (!defined ($cs_ref))
      {
	#LOG FATAL ERROR MESSAGE
      };

    $string .= $$cs_ref;

    $string .= ")\n";		# End ( list_overlays

    $string .= ")\n";		# End ( xbone

    $string .= "XboneEOC\n";	# End record

    return (\$string);

  }





1;                            # Insure TRUE return if module is interpreted.