view release on metacpan or  search on metacpan

lib/SOAP/Clean/CGI.pm  view on Meta::CPAN

  my $request_method = $ENV{REQUEST_METHOD} || 0;
  my $soapaction = $ENV{HTTP_SOAPACTION} || 0;
  my $content_type = $ENV{CONTENT_TYPE} || 0;
  my $query_string = $ENV{QUERY_STRING} || 0;


  my $result;
  # Determine how the request should be handled.
  if ( $soapaction || $content_type =~ 'application/soap\+xml' ) {
    # if the SOAPAction: header appears or the Content-type is
    # application/soap+xml, then it process it as a soap request, not
    # matter what the request method was.
    $result = $self->handle_soap($content_type =~ 'text/xml');
  } else {
    # use the request method to decide how to handle it.
    if ( $request_method eq "POST" ) {
      # POST method
      $result = $self->handle_post();
    } elsif ( $request_method eq "GET" ) {
      # GET method. Use the query string to decide how to handle.
      if ( lc($query_string) eq "wsdl" ) {
	$result = $self->handle_wsdl();
      } else {
	$result = $self->handle_get();
      }
    } else {
      # No request method? The script must be being called interactively
      # for debugging purposes. Handle it as SOAP.
      $result = $self->handle_soap(0);
    }
  }

  return $result;

}

########################################################################

sub handle_soap {
  my ($self,$content_type_is_text_xml) = @_;

  # Set the handler for die calls.
  $SIG{__DIE__} = \&soap_die_handler;

  my $server_urn = $self->{urn};
  defined($server_urn) || assert(0,"No server URN");
  my $server_name = $self->{name};
  defined($server_name) || assert(0,"No server name");

  # Read the request from STDIN
  my $request = xml_from_fh(\*STDIN);
  defined($request) || assert(0,"Can't parse request?!?");

  # Take a SOAP request. Parse it and extract the method name and
  # arguments. Call the appropriate function for the method. Package the
  # results into a SOAP response and return it.

  # Here we verify the digital signature if the server wants to check
  # digital signatures
  if (defined($self->{dsig})) { verify_envelope($self,$request); }

  #### DECRYPTION HERE #########
  if (defined($self->{enc})) { decrypt_body($self,$request); }

  my $envelope = xml_get_child($request,$SOAP_ENV,'Envelope');
  assert(defined($envelope));
  my $body = xml_get_child($envelope,$SOAP_ENV,'Body');
  assert(defined($body));

  # The body contains a single element which is the message.
  my @children = xml_get_children($body);
  $#children == 0 ||
    assert(0,"Error! file \"".__FILE__."\", line ".__LINE__);
  my $message = $children[0];

  # The method name is the node name of the message.
  my ($method_urn,$method_name) = xml_get_name($message);
  # The method name must appear in the right namespace.
  ($method_urn eq $server_urn) ||
    assert(0,"Method name not in the server namespace");

  # The method arguments are the children of the message.
  my %request_args = ();
  foreach my $arg ( xml_get_children($message) ) {
    my ($arg_ns,$arg_name) = xml_get_name($arg);
    # The arg name must appear in the right namespace.
    ($arg_ns eq $server_urn) ||
      assert(0,"Arg name not in the server namespace");

    $request_args{$arg_name} = $arg;
  }

  # %response_args = call $method_name with %request_args;
  my %response_args = $self->_dispatch_method($method_name, %request_args);

  # Put the response arguments together in a list.
  my @response_args_list = ();
  foreach my $k (keys %response_args) {
    push @response_args_list, $response_args{$k};
  }

  # Put together $method_name."Response" with %responses;
  my $response = 
    document(element("SOAP-ENV:Envelope",
		     namespace("SOAP-ENV",$SOAP_ENV),
		     namespace("SOAP-ENC",$SOAP_ENC),
		     namespace("xsi",$xsi),
		     namespace("xsd",$xsd),
		     namespace("server",$server_urn),
		     element("SOAP-ENV:Header"),
		     element("SOAP-ENV:Body",
			     element("server:".$method_name."Result",
				     @response_args_list))));

  # fixme: encrypt if need be

  # Use whatever content type that this client used.
  my $type;
  if ( $content_type_is_text_xml ) {
    # .NET requires this,...
    $type = 'text/xml';
  } else {
    # but SOAP 1.2 requires this,
    $type = 'application/soap+xml';
  }
    $type = 'text/xml';
  print header(-type=>$type,
 	       -charset=>'utf-8');
  xml_to_fh($response,\*STDOUT);

  return 0;
}

########################################################################

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

  # Set the handler for die calls.
  $SIG{__DIE__} = \&html_die_handler;

  my $server_urn = $self->{urn};
  defined($server_urn) || assert(0,"No server URN");
  my $server_name = $self->{name};
  defined($server_name) || assert(0,"No server name");

  my $method_name = param("_method_");

  print header,
    start_html($server_name.": Results"),
      h1($server_name.": Results"), p;

  if (!param()) {
    print "No params? How did you manage that?", hr;
    print end_html;
    return 1;
  }

  # Throw an error if either dsig or enc was expected.
  if (defined($self->{dsig})) { 
    assert(0,"No digitial signatures for POST's");
  }
  if (defined($self->{enc})) { 
    assert(0,"No encryption for POST's");
  }

  # Determine the formal parameters based on the method name
  my @formal_params;
  if ( $method_name eq "Call" || $method_name eq "Spawn" ) {
    my %h = ();
    foreach my $p ( @{$self->{params}} ) {
      $h{$$p{name}} = $p;
    }
    foreach my $n ( @{$self->{in_order}} ) {
      my $p = $h{$n};
      assert(defined($p));
      if ( $$p{direc} eq "out" ) { 
	# nothing
      } else {
	push @formal_params, $p;
      }
    }
  } elsif ( $method_name eq "Running" || $method_name eq "Results" ) {
    @formal_params = ({ name=> 'uid', 
			direc=> 'in', 
			mech=> 'val',
			type=> 'string',
		      });
  } else {
    die;
  }

  # Parse the actual parameters.

  my %request_args = ();
  foreach my $p ( @formal_params ) {
    my $name = $$p{name};
    assert(defined($p),"No value for $name");
    my $mech = $$p{mech};
    my $type = $$p{type};
    my $value;
    if ( $mech eq 'val' ) {
      $value = param($name);
    } elsif ( $mech eq 'file' ) {
      my $fh = param($name);	#upload($name);
      assert($fh,"File $name is missing");
      $value = '';
      # deleteme
      #print pre("+".$fh."\n"),p;
      while (<$fh>) {
	# deleteme
	#print pre("*\n"),p;
	$value .= $_;
      }
    } else {
      assert(0);
    }
    if ( $value ne '') {
      $request_args{$name} = $value;
    }