X-Git-Url: http://git.rot13.org/?p=perl-cwmp.git;a=blobdiff_plain;f=lib%2FCWMP%2FServer.pm;h=055e265dad014e3e6c7954949dd005c85f290c61;hp=5a452c25114d76f01acc7d94d26980b7942c481a;hb=5a913f2c18fe1894cda0144870684e9d559352d2;hpb=4c0e11c9fce3d7cdffc724ae4b3b9754edf72e82

diff --git a/lib/CWMP/Server.pm b/lib/CWMP/Server.pm
index 5a452c2..055e265 100644
--- a/lib/CWMP/Server.pm
+++ b/lib/CWMP/Server.pm
@@ -10,6 +10,7 @@ port
 session
 background
 debug
+create_dump
 
 server
 / );
@@ -20,6 +21,12 @@ use CWMP::Queue;
 use Carp qw/confess/;
 use Data::Dump qw/dump/;
 
+use IO::Socket::INET;
+use File::Path qw/mkpath/;
+use File::Slurp;
+
+use URI::Escape;
+
 =head1 NAME
 
 CWMP::Server - description
@@ -58,21 +65,9 @@ sub new {
 
 	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->server(
-		CWMP::Server::Helper->new({
-			proto => 'tcp',
-			port => $self->port,
-			session => $self->session,
-			debug => $self->debug,
-			background => $self->background,
-		})
-	);
-
 	return $self;
 }
 
@@ -83,69 +78,106 @@ sub new {
 sub run {
 	my $self = shift;
 
-	$self->server->run;
-}
+	my $server = IO::Socket::INET->new(
+			Proto     => 'tcp',
+			LocalPort => $self->port,
+			Listen    => SOMAXCONN,
+			Reuse     => 1
+	) || die "can't start server on ", $self->port, ": $!";
 
-package CWMP::Server::Helper;
+	warn "ACS waiting for request on port ", $self->port, "\n";
 
-use warnings;
-use strict;
+	while (1) {
+		my $client = $server->accept() || next; # ALARM trickle us
 
-use base qw/Net::Server/;
-use Carp qw/confess/;
-use Data::Dump qw/dump/;
+		my $count = 0;
 
-sub options {
-	my $self     = shift;
-	my $prop     = $self->{'server'};
-	my $template = shift;
+		my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
 
-	### setup options in the parent classes
-	$self->SUPER::options($template);
+		while ( $self->sock_session( $client, $session ) ) {
+			$count++;
+			warn "# finished request $count, waiting for next one\n";
+		}
 
-	# new single-value options
-	foreach my $p ( qw/ session debug / ) {
-		$prop->{ $p } ||= undef;
-		$template->{ $p } = \$prop->{ $p };
+		warn "# connection to ", $client->peerhost, " closed\n";
 	}
 
-	# new multi-value options
-#	foreach my $p ( qw/ default_queue / ) {
-#		$prop->{ $p } ||= [];
-#		$template->{ $p } = $prop->{ $p };
-#	}
 }
 
+my $dump_by_ip;
 
-=head2 process_request
+sub sock_session {
+	my ( $self, $sock, $session ) = @_;
 
-=cut
+	my $request = <$sock>;
+	return unless $request;
+	my $ip = $sock->peerhost;
 
-sub process_request {
-	my $self = shift;
+	my $headers;
 
-	my $prop = $self->{server};
-	confess "no server in ", ref( $self ) unless $prop;
-	my $sock = $prop->{client};
-	confess "no sock in ", ref( $self ) unless $sock;
+	while ( my $header = <$sock> ) {
+		$request .= $header;
+		chomp $header;
+		last if $header =~ m{^\s*$};
+		my ( $n, $v ) = split(/:\s*/, $header);
+		$v =~ s/[\r\n]+$//;
+		$headers->{ lc $n } = $v;
+	}
 
-	my $sess = $prop->{session} || confess "no session";
+	warn "<<<< $ip START\n$request\n";
 
-	eval  {
-		$sess->{sock} = $sock;
-		$sess->{debug} = $prop->{debug};
+	return $sock->connected unless $headers;
 
-		my $session = CWMP::Session->new( $sess ) || confess "can't create session from ",dump( $sess );
+	warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
 
-		while ( $session->process_request ) {
-			warn "...waiting for next request from CPE...\n";
+	my $body;
+	if ( my $len = $headers->{'content-length'} ) {
+		read( $sock, $body, $len );
+	} elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
+		while ( my $len = <$sock> ) {
+			$len =~ s/[\r\n]+$//;
+			$len = hex($len);
+			last if $len == 0;
+			read( $sock, my $chunk, $len );
+			$body .= $chunk;
+			my $padding = <$sock>;
 		}
-	};
+	} else {
+		warn "empty request\n";
+	}
+
+	warn "$body\n<<<< $ip END\n";
 
-	warn "ERROR: $@\n" if $@;
 
-	warn "...returning to accepting new connections\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}++;
+
+	if ( $self->create_dump ) {
+		mkpath "dump/$ip" unless -e "dump/$ip";
+		write_file( sprintf("dump/%s/%04d.request", $ip, $dump_nr), "$request\r\n$body" );
+		write_file( sprintf("dump/%s/%04d.response", $ip, $dump_nr ), $response );
+	}
+
+	warn ">>>> $ip START\n$response\n>>>> $ip END\n";
+	print $sock $response;
+
+	return $sock->connected;
 
 }
 
+
 1;