From 7b15acb7d67a6679a3c498850a4fffa1459eb0b9 Mon Sep 17 00:00:00 2001 From: Dobrica Pavlinusic Date: Sat, 6 Mar 2010 21:40:17 +0000 Subject: [PATCH] simplify HTTP server implementation use IO::Socket::INET to implement simpliest possible persistent connection with CPE client. git-svn-id: https://perl-cwmp.googlecode.com/svn/trunk@252 836a5e1a-633d-0410-964b-294494ad4392 --- lib/CWMP/Server.pm | 128 +++++++++++++++++++++++++------------------- lib/CWMP/Session.pm | 82 ++++------------------------ 2 files changed, 83 insertions(+), 127 deletions(-) diff --git a/lib/CWMP/Server.pm b/lib/CWMP/Server.pm index ff2611c..f69ece6 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,10 @@ use CWMP::Queue; use Carp qw/confess/; use Data::Dump qw/dump/; +use IO::Socket::INET; +use File::Path qw/mkpath/; +use File::Slurp; + =head1 NAME CWMP::Server - description @@ -63,16 +68,6 @@ sub new { $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,70 +78,95 @@ 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 "listen on ", $server->sockhost, ":", $server->sockport, "\n"; -use warnings; -use strict; + while (1) { + my $client = $server->accept() || next; # ALARM trickle us -#use base qw/Net::Server/; -use base qw/Net::Server::Fork/; -use Carp qw/confess/; -use Data::Dump qw/dump/; + my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision"; -sub options { - my $self = shift; - my $prop = $self->{'server'}; - my $template = shift; - - ### setup options in the parent classes - $self->SUPER::options($template); + while ( $self->sock_session( $client, $session ) ) { + warn "# another 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"; + + return $sock->connected unless $headers; + +warn dump( $headers ); + + warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' ); + + my $body; + if ( my $len = $headers->{'content-length'} ) { + 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; +warn "reading $len bytes\n"; + read( $sock, my $chunk, $len ); +warn "|$chunk| $len == ", length($chunk); + $body .= $chunk; + my $padding = <$sock>; +warn "padding ",dump($padding); + } + } else { + warn "empty request\n"; + } - eval { - $sess->{sock} = $sock; - $sess->{debug} = $prop->{debug}; + warn "$body\n<<<< $ip END\n"; - my $session = CWMP::Session->new( $sess ) || confess "can't create session from ",dump( $sess ); + my $response = $session->process_request( $ip, $body ); - while ( $session->process_request ) { - warn "...waiting for next request from CPE...\n" if $prop->{debug}; - } - }; + 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 "ERROR: $@\n" if $@; + warn ">>>> $ip START\n$response\n>>>> $ip END\n"; + print $sock $response; - warn "...returning to accepting new connections\n" if $prop->{debug}; + return $sock->connected; } + 1; diff --git a/lib/CWMP/Session.pm b/lib/CWMP/Session.pm index 64faa00..25dd084 100644 --- a/lib/CWMP/Session.pm +++ b/lib/CWMP/Session.pm @@ -15,11 +15,8 @@ state store / ); -use HTTP::Daemon; use Data::Dump qw/dump/; use Carp qw/carp confess cluck croak/; -use File::Slurp; -use File::Path qw/mkpath/; use CWMP::Request; use CWMP::Methods; @@ -48,14 +45,10 @@ sub new { my $class = shift; my $self = $class->SUPER::new( @_ ); - confess "need sock" unless $self->sock; confess "need store" unless $self->store; - my $peerhost = $self->sock->peerhost || confess "can't get sock->peerhost"; $self->debug( 0 ) unless $self->debug; - warn "created ", __PACKAGE__, "(", dump( @_ ), ") for $peerhost\n" if $self->debug; - my $store_obj = CWMP::Store->new({ debug => $self->debug, %{ $self->store }, @@ -83,66 +76,20 @@ of requests in single session. =cut -my $dump_by_ip; sub process_request { - my $self = shift; - - my $sock = $self->sock || die "no sock?"; - -# die "not IO::Socket::INET but ", ref( $sock ) unless ( ref($sock) eq 'Net::Server::Proto::TCP' ); - - if ( ! $sock->connected ) { - warn "SOCKET NOT CONNECTED\n"; - return 0; - } - - bless $sock, 'HTTP::Daemon::ClientConn'; - - # why do I have to do this? - # solution from http://use.perl.org/~Matts/journal/12896 - ${*$sock}{'httpd_daemon'} = HTTP::Daemon->new; - - my $r = $sock->get_request; - - if ( ! $r ) { - warn "WARNING: can't get_request\n"; - return 0; - } - - my $ip = $sock->peerhost || confess "can't get peerhost from sock: $!"; - - my $xml = $r->content; + my ( $self, $ip, $xml ) = @_; my $size = length( $xml ); - warn "<<<< $ip [" . localtime() . "] ", $r->method, " ", $r->uri, " $size bytes\n"; - - my $dump_nr = $dump_by_ip->{$ip}++; - my $file = sprintf("./dump/%s/%04d.request", $ip, $dump_nr); - - if ( $self->create_dump ) { - mkpath "dump/$ip" unless -e "dump/$ip"; - write_file( $file, $r->as_string ); - warn "### request dumped to file: $file\n" if $self->debug; - } - my $state; if ( $size > 0 ) { - warn "no SOAPAction header in ",dump($xml) unless defined ( $r->header('SOAPAction') ); - warn "## request payload: ",length($xml)," bytes\n$xml\n" if $self->debug; $state = CWMP::Request->parse( $xml ); - if ( defined( $state->{_trigger} ) && $self->create_dump ) { - my $type = sprintf("dump/%s/%04d-%s", $ip, $dump_nr, $state->{_trigger}); - $file =~ s!^.*?([^/]+)$!$1!; #!vim - symlink $file, $type || warn "can't symlink $file -> $type: $!"; - } - warn "## acquired state = ", dump( $state ), "\n" if $self->debug; if ( ! defined( $state->{DeviceID} ) ) { @@ -167,14 +114,14 @@ sub process_request { #warn "last request state = ", dump( $state ), "\n" if $self->debug > 1; } - $sock->send(join("\r\n", + my $out = join("\r\n", 'HTTP/1.1 200 OK', 'Content-Type: text/xml; charset="utf-8"', - 'Server: PerlCWMP/42', - 'SOAPServer: PerlCWMP/42' - )."\r\n"); + 'Server: Perl-CWMP/42', + 'SOAPServer: Perl-CWMP/42' + ) . "\r\n"; - $sock->send( "Set-Cookie: ID=" . $state->{ID} . "; path=/\r\n" ) if ( $state->{ID} ); + $out .= "Set-Cookie: ID=" . $state->{ID} . "; path=/\r\n" if $state->{ID}; my $uid = $self->store->state_to_uid( $state ); @@ -204,17 +151,13 @@ sub process_request { $xml = ''; } - $sock->send( "Content-Length: " . length( $xml ) . "\r\n\r\n" ); - if (length($xml)) { - $sock->send( $xml ) or die "can't send response"; - } - - warn ">>>> " . $ip . " [" . localtime() . "] sent ", length( $xml )," bytes $to_uid"; + $out .= "Content-Length: " . length( $xml ) . "\r\n\r\n"; + $out .= $xml if length($xml); $job->finish if $job; warn "### request over for $uid\n" if $self->debug; - return 1; # next request + return $out; # next request }; =head2 dispatch @@ -237,13 +180,6 @@ sub dispatch { warn ">>> dispatching to $dispatch with args ",dump( $args ),"\n"; my $xml = $response->$dispatch( $self->state, $args ); warn "## response payload: ",length($xml)," bytes\n$xml\n" if $self->debug; - if ( $self->create_dump ) { - my $ip = $self->sock->peerhost || confess "can't get sock->peerhost: $!"; - my $dump_nr = $dump_by_ip->{$ip}++; - my $file = sprintf("dump/%s/%04d.response", $ip, $dump_nr ); - write_file( $file, $xml ); - warn "### response dump: $file\n" if $self->debug; - } return $xml; } else { confess "can't dispatch to $dispatch"; -- 2.20.1