evil hack to allow introspection of running server

[perl-cwmp.git] / lib / CWMP / Server.pm

diff --git a/lib/CWMP/Server.pm b/lib/CWMP/Server.pm
index f69ece6..055e265 100644 (file)
--- a/lib/CWMP/Server.pm
+++ b/lib/CWMP/Server.pm
@@ -25,6 +25,8 @@ use IO::Socket::INET;
 use File::Path qw/mkpath/;
 use File::Slurp;
 
 use File::Path qw/mkpath/;
 use File::Slurp;
 

+use URI::Escape;
+

 =head1 NAME
 
 CWMP::Server - description
 =head1 NAME
 
 CWMP::Server - description


@@ -63,8 +65,6 @@ sub new {
 
        warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
 
 
        warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
 

-       warn "ACS waiting for request on port ", $self->port, "\n";
-

        $self->debug( 0 ) unless $self->debug;
        warn "## debug level: ", $self->debug, "\n" if $self->debug;
 
        $self->debug( 0 ) unless $self->debug;
        warn "## debug level: ", $self->debug, "\n" if $self->debug;
 


@@ -85,15 +85,18 @@ sub run {
                        Reuse     => 1
        ) || die "can't start server on ", $self->port, ": $!";
 
                        Reuse     => 1
        ) || die "can't start server on ", $self->port, ": $!";
 

-       warn "listen on ", $server->sockhost, ":", $server->sockport, "\n";
+       warn "ACS waiting for request on port ", $self->port, "\n";

 
        while (1) {
                my $client = $server->accept() || next; # ALARM trickle us
 
 
        while (1) {
                my $client = $server->accept() || next; # ALARM trickle us
 

+               my $count = 0;
+

                my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
 
                while ( $self->sock_session( $client, $session ) ) {
                my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
 
                while ( $self->sock_session( $client, $session ) ) {

-                       warn "# another one\n";
+                       $count++;
+                       warn "# finished request $count, waiting for next one\n";

                }
 
                warn "# connection to ", $client->peerhost, " closed\n";
                }
 
                warn "# connection to ", $client->peerhost, " closed\n";


@@ -125,8 +128,6 @@ sub sock_session {
 
        return $sock->connected unless $headers;
 
 
        return $sock->connected unless $headers;
 

-warn dump( $headers );
-

        warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 
        my $body;
        warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 
        my $body;


@@ -134,16 +135,12 @@ warn dump( $headers );
                read( $sock, $body, $len );
        } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
                while ( my $len = <$sock> ) {
                read( $sock, $body, $len );
        } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
                while ( my $len = <$sock> ) {

-warn "chunked ",dump($len);

                        $len =~ s/[\r\n]+$//;
                        $len = hex($len);
                        last if $len == 0;
                        $len =~ s/[\r\n]+$//;
                        $len = hex($len);
                        last if $len == 0;

-warn "reading $len bytes\n";

                        read( $sock, my $chunk, $len );
                        read( $sock, my $chunk, $len );

-warn "|$chunk| $len == ", length($chunk);

                        $body .= $chunk;
                        my $padding = <$sock>;
                        $body .= $chunk;
                        my $padding = <$sock>;

-warn "padding ",dump($padding);

                }
        } else {
                warn "empty request\n";
                }
        } else {
                warn "empty request\n";


@@ -151,6 +148,20 @@ warn "padding ",dump($padding);
 
        warn "$body\n<<<< $ip END\n";
 
 
        warn "$body\n<<<< $ip END\n";
 

+
+       # XXX evil security hole to eval code over web to inspect it
+       if ( $self->debug && $headers->{'user-agent'} =~ m{Mozilla} ) {
+               my $out = '';
+               if ( $request =~ m{^GET /(\$.+) HTTP/} ) {
+                       my $eval = uri_unescape $1;
+                       $out = dump( eval $eval );
+                       $out .= "ERROR: $@\n" if $@;
+                       warn "EVAL $eval = $out\n";
+               }
+               print $sock "HTTP/1.1 200 OK\r\nContent-type: text/plain\r\nConnection: close\r\n\r\n$out";
+               return 0;
+       }
+

        my $response = $session->process_request( $ip, $body );
 
        my $dump_nr = $dump_by_ip->{$ip}++;
        my $response = $session->process_request( $ip, $body );
 
        my $dump_nr = $dump_by_ip->{$ip}++;