view release on metacpan or  search on metacpan

lib/SOAP/Transport/HTTP.pm  view on Meta::CPAN

sub setDebugLogger {
    my ($self,$logger) = @_;
    $self->{debug_logger} = $logger;
}

sub new {
    my $class = shift;
    #print "HTTP.pm DEBUG: in sub new\n";

    return $class if ref $class;    # skip if we're already object...

    if ( !grep { $_ eq $USERAGENT_CLASS } @ISA ) {
        push @ISA, $USERAGENT_CLASS;
    }

    eval("require $USERAGENT_CLASS")
      or die "Could not load UserAgent class $USERAGENT_CLASS: $@";

    require HTTP::Request;
    require HTTP::Headers;

    patch() if $SOAP::Constants::PATCH_HTTP_KEEPALIVE;

    my ( @params, @methods );
    while (@_) {
        $class->can( $_[0] )
          ? push( @methods, shift() => shift )
          : push( @params,  shift );
    }
    my $self = $class->SUPER::new(@params);

    die
"SOAP::Transport::HTTP::Client must inherit from LWP::UserAgent, or one of its subclasses"
      if !$self->isa("LWP::UserAgent");

    $self->agent( join '/', 'SOAP::Lite', 'Perl',
        $SOAP::Transport::HTTP::VERSION );
    $self->options( {} );

    $self->http_request( HTTP::Request->new() );

    while (@methods) {
        my ( $method, $params ) = splice( @methods, 0, 2 );
        # ssl_opts takes a hash, not a ref - see RT 107924
        if (ref $params eq 'HASH' && $method eq 'ssl_opts') {
            $self->$method( %$params );
            next;
        }
        $self->$method( ref $params eq 'ARRAY' ? @$params : $params );
    }

    SOAP::Trace::objects('()');

    $self->setDebugLogger(\&SOAP::Trace::debug);

    return $self;
}

sub send_receive {
    my ( $self, %parameters ) = @_;
    my ( $context, $envelope, $endpoint, $action, $encoding, $parts ) =
      @parameters{qw(context envelope endpoint action encoding parts)};

    $encoding ||= 'UTF-8';

    $endpoint ||= $self->endpoint;

    my $method = 'POST';
    $COMPRESS = 'gzip';

    $self->options->{is_compress} ||=
      exists $self->options->{compress_threshold}
      && eval { require Compress::Zlib };

    # Initialize the basic about the HTTP Request object
    my $http_request = $self->http_request()->clone();

    # $self->http_request(HTTP::Request->new);
    $http_request->headers( HTTP::Headers->new );

    # TODO - add application/dime
    $http_request->header(
        Accept => ['text/xml', 'multipart/*', 'application/soap'] );
    $http_request->method($method);
    $http_request->url($endpoint);

    no strict 'refs';
    if ($parts) {
        my $packager = $context->packager;
        $envelope = $packager->package( $envelope, $context );
        for my $hname ( keys %{$packager->headers_http} ) {
            $http_request->headers->header(
                $hname => $packager->headers_http->{$hname} );
        }

        # TODO - DIME support
    }

  COMPRESS: {
        my $compressed =
             !exists $nocompress{$endpoint}
          && $self->options->{is_compress}
          && ( $self->options->{compress_threshold} || 0 ) < length $envelope;


        my $original_encoding = $http_request->content_encoding;

        while (1) {

            # check cache for redirect
            $endpoint = $redirect{$endpoint} if exists $redirect{$endpoint};

            # check cache for M-POST
            $method = 'M-POST' if exists $mpost{$endpoint};

          # what's this all about?
          # unfortunately combination of LWP and Perl 5.6.1 and later has bug
          # in sending multibyte characters. LWP uses length() to calculate
          # content-length header and starting 5.6.1 length() calculates chars
          # instead of bytes. 'use bytes' in THIS file doesn't work, because
          # it's lexically scoped. Unfortunately, content-length we calculate
          # here doesn't work either, because LWP overwrites it with
          # content-length it calculates (which is wrong) AND uses length()
          # during syswrite/sysread, so we are in a bad shape anyway.
          #
          # what to do? we calculate proper content-length (using
          # bytelength() function from SOAP::Utils) and then drop utf8 mark
          # from string (doing pack with 'C0A*' modifier) if length and
          # bytelength are not the same
            my $bytelength = SOAP::Utils::bytelength($envelope);
            if ($] < 5.008) {
                $envelope = pack( 'C0A*', $envelope );
            }
            else {
                require Encode;
                $envelope = Encode::encode($encoding, $envelope);
                $bytelength = SOAP::Utils::bytelength($envelope);
            }
            #  if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK
            #      && length($envelope) != $bytelength;

            # compress after encoding
            # doing it before breaks the compressed content (#74577)
            $envelope = Compress::Zlib::memGzip($envelope) if $compressed;

            $http_request->content($envelope);
            $http_request->protocol('HTTP/1.1');

            $http_request->proxy_authorization_basic( $ENV{'HTTP_proxy_user'},
                $ENV{'HTTP_proxy_pass'} )
              if ( $ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'} );

            # by Murray Nesbitt
            if ( $method eq 'M-POST' ) {
                my $prefix = sprintf '%04d', int( rand(1000) );
                $http_request->header(
                    Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix! );
                $http_request->header( "$prefix-SOAPAction" => $action )
                  if defined $action;
            }
            else {
                $http_request->header( SOAPAction => $action )
                  if defined $action;
            }

            #            $http_request->header(Expect => '100-Continue');

            # allow compress if present and let server know we could handle it
            $http_request->header( 'Accept-Encoding' =>
                  [$SOAP::Transport::HTTP::Client::COMPRESS] )
              if $self->options->{is_compress};

            $http_request->content_encoding(
                $SOAP::Transport::HTTP::Client::COMPRESS)
              if $compressed;

            if ( !$http_request->content_type ) {
                $http_request->content_type(
                    join '; ',
                    $SOAP::Constants::DEFAULT_HTTP_CONTENT_TYPE,
                    !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding
                    ? 'charset=' . lc($encoding)
                    : () );
            }
            elsif ( !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ) {
                my $tmpType = $http_request->headers->header('Content-type');

                # $http_request->content_type($tmpType.'; charset=' . lc($encoding));
                my $addition = '; charset=' . lc($encoding);
                $http_request->content_type( $tmpType . $addition )
                  if ( $tmpType !~ /$addition/ );
            }

            $http_request->content_length($bytelength) unless $compressed;
            SOAP::Trace::transport($http_request);
            &{$self->{debug_logger}}($http_request->as_string);

            $self->SUPER::env_proxy if $ENV{'HTTP_proxy'};

            # send and receive the stuff.
            # TODO maybe eval this? what happens on connection close?
            $self->http_response( $self->SUPER::request($http_request) );
            SOAP::Trace::transport( $self->http_response );
            &{$self->{debug_logger}}($self->http_response->as_string);

            # 100 OK, continue to read?
            if ( (
                       $self->http_response->code == 510
                    || $self->http_response->code == 501
                )
                && $method ne 'M-POST'
              ) {
                $mpost{$endpoint} = 1;
            }
            elsif ( $self->http_response->code == 415 && $compressed ) {

                # 415 Unsupported Media Type
                $nocompress{$endpoint} = 1;
                $envelope = Compress::Zlib::memGunzip($envelope);
                $http_request->headers->remove_header('Content-Encoding');
                redo COMPRESS;    # try again without compression
            }
            else {
                last;
            }
        }
    }

    $redirect{$endpoint} = $self->http_response->request->url
      if $self->http_response->previous
          && $self->http_response->previous->is_redirect;

    $self->code( $self->http_response->code );
    $self->message( $self->http_response->message );
    $self->is_success( $self->http_response->is_success );
    $self->status( $self->http_response->status_line );

    # Pull out any cookies from the response headers
    $self->{'_cookie_jar'}->extract_cookies( $self->http_response )
      if $self->{'_cookie_jar'};

    my $content =
      ( $self->http_response->content_encoding || '' ) =~
      /\b$SOAP::Transport::HTTP::Client::COMPRESS\b/o
      && $self->options->{is_compress}
      ? Compress::Zlib::memGunzip( $self->http_response->content )
      : ( $self->http_response->content_encoding || '' ) =~ /\S/ ? die
"Can't understand returned Content-Encoding (@{[$self->http_response->content_encoding]})\n"
      : $self->http_response->content;

    return $self->http_response->content_type =~ m!^multipart/!i
      ? join( "\n", $self->http_response->headers_as_string, $content )
      : $content;
}

# ======================================================================

package SOAP::Transport::HTTP::Server;

use vars qw(@ISA $COMPRESS);
@ISA = qw(SOAP::Server);

use URI;

$COMPRESS = 'deflate';

sub DESTROY { SOAP::Trace::objects('()') }

sub setDebugLogger {
    my ($self,$logger) = @_;
    $self->{debug_logger} = $logger;
}

sub new {
    require LWP::UserAgent;
    my $self = shift;
    return $self if ref $self;    # we're already an object

    my $class = $self;
    $self = $class->SUPER::new(@_);
    $self->{'_on_action'} = sub {
        ( my $action = shift || '' ) =~ s/^(\"?)(.*)\1$/$2/;
        die
"SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n"
          if $action
              && $action ne join( '#', @_ )
              && $action ne join( '/', @_ )
              && ( substr( $_[0], -1, 1 ) ne '/'
                  || $action ne join( '', @_ ) );
    };
    SOAP::Trace::objects('()');

    $self->setDebugLogger(\&SOAP::Trace::debug);

    return $self;
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(request response)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            @_
              ? ( $self->{$field} = shift, return $self )
              : return $self->{$field};
        };
    }
}

sub handle {
    my $self = shift->new;

    &{$self->{debug_logger}}($self->request->content);

    if ( $self->request->method eq 'POST' ) {
        $self->action( $self->request->header('SOAPAction') || undef );
    }
    elsif ( $self->request->method eq 'M-POST' ) {
        return $self->response(
            HTTP::Response->new(
                510,    # NOT EXTENDED
"Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI"
            ) )
          if $self->request->header('Man') !~
              /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/;
        $self->action( $self->request->header("$1-SOAPAction") || undef );
    }
    else {
        return $self->response(
            HTTP::Response->new(405) )    # METHOD NOT ALLOWED
    }

    my $compressed =
      ( $self->request->content_encoding || '' ) =~ /\b$COMPRESS\b/;
    $self->options->{is_compress} ||=
      $compressed && eval { require Compress::Zlib };

    # signal error if content-encoding is 'deflate', but we don't want it OR
    # something else, so we don't understand it
    return $self->response(
        HTTP::Response->new(415) )        # UNSUPPORTED MEDIA TYPE
      if $compressed && !$self->options->{is_compress}
          || !$compressed
          && ( $self->request->content_encoding || '' ) =~ /\S/;

    my $content_type = $self->request->content_type || '';

# in some environments (PerlEx?) content_type could be empty, so allow it also
# anyway it'll blow up inside ::Server::handle if something wrong with message
# TBD: but what to do with MIME encoded messages in THOSE environments?
    return $self->make_fault( $SOAP::Constants::FAULT_CLIENT,
            "Content-Type must be 'text/xml,' 'multipart/*,' "
          . "'application/soap+xml,' 'or 'application/dime' instead of '$content_type'"
      )
      if !$SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE
          && $content_type
          && $content_type ne 'application/soap+xml'
          && $content_type ne 'text/xml'
          && $content_type ne 'application/dime'
          && $content_type !~ m!^multipart/!;

    # TODO - Handle the Expect: 100-Continue HTTP/1.1 Header
    if ( defined( $self->request->header("Expect") )
        && ( $self->request->header("Expect") eq "100-Continue" ) ) {

    }

    # TODO - this should query SOAP::Packager to see what types it supports,
    #      I don't like how this is hardcoded here.
    my $content =
      $compressed
      ? Compress::Zlib::uncompress( $self->request->content )
      : $self->request->content;

    my $response = $self->SUPER::handle(
        $self->request->content_type =~ m!^multipart/!
        ? join( "\n", $self->request->headers_as_string, $content )
        : $content
    ) or return;

    &{$self->{debug_logger}}($response);

    $self->make_response( $SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response );
}

sub make_fault {
    my $self = shift;
    $self->make_response(
        $SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)
    );
    return;
}

sub make_response {
    my ( $self, $code, $response ) = @_;

    my $encoding = $1
      if $response =~ /^<\?xml(?: version="1.0"| encoding="([^\"]+)")+\?>/;

    $response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>!
      if $self->request->content_type eq 'multipart/form-data';

    $self->options->{is_compress} ||=
      exists $self->options->{compress_threshold}
      && eval { require Compress::Zlib };

    my $compressed = $self->options->{is_compress}
      && grep( /\b($COMPRESS|\*)\b/,
        $self->request->header('Accept-Encoding') )
      && ( $self->options->{compress_threshold} || 0 ) <
      SOAP::Utils::bytelength $response;

    if ($] > 5.007 && $encoding) {
        require Encode;
        $response = Encode::encode( $encoding, $response );
    }

    $response = Compress::Zlib::compress($response) if $compressed;

# this next line does not look like a good test to see if something is multipart
# perhaps a /content-type:.*multipart\//gi is a better regex?
    my ($is_multipart) =
      ( $response =~ /^content-type:.* boundary="([^\"]*)"/im );

    $self->response(
        HTTP::Response->new(
            $code => undef,
            HTTP::Headers->new(
                'SOAPServer' => $self->product_tokens,
                $compressed ? ( 'Content-Encoding' => $COMPRESS ) : (),
                'Content-Type' => join( '; ',
                    'text/xml',
                    !$SOAP::Constants::DO_NOT_USE_CHARSET
                      && $encoding ? 'charset=' . lc($encoding) : () ),
                'Content-Length' => SOAP::Utils::bytelength $response
            ),
            $response,
        ) );

    $self->response->headers->header( 'Content-Type' =>
'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'
          . $is_multipart
          . '"' )
      if $is_multipart;
}

# ->VERSION leaks a scalar every call - no idea why.
sub product_tokens {
    join '/', 'SOAP::Lite', 'Perl', $SOAP::Transport::HTTP::VERSION;
}

# ======================================================================

package SOAP::Transport::HTTP::CGI;

use vars qw(@ISA);
@ISA = qw(SOAP::Transport::HTTP::Server);

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;

    my $class = ref($self) || $self;
    $self = $class->SUPER::new(@_);
    SOAP::Trace::objects('()');

    return $self;
}

sub make_response {
    my $self = shift;
    $self->SUPER::make_response(@_);
}

sub handle {
    my $self = shift->new;

    my $length = $ENV{'CONTENT_LENGTH'} || 0;

    # if the HTTP_TRANSFER_ENCODING env is defined, set $chunked if it's chunked*
    # else to false
    my $chunked = (defined $ENV{'HTTP_TRANSFER_ENCODING'}
        && $ENV{'HTTP_TRANSFER_ENCODING'} =~ /^chunked.*$/) || 0;


    my $content = q{};

    if ($chunked) {
        my $buffer;
        binmode(STDIN);
        while ( read( STDIN, my $buffer, 1024 ) ) {
            $content .= $buffer;