--- google/lib/CWMP/Server.pm 2007/06/19 21:35:35 51 +++ google/lib/CWMP/Session.pm 2007/10/21 22:58:22 111 @@ -1,5 +1,5 @@ # Dobrica Pavlinusic, 06/18/07 10:19:50 CEST -package CWMP::Server; +package CWMP::Session; use strict; use warnings; @@ -7,60 +7,58 @@ use base qw/Class::Accessor/; __PACKAGE__->mk_accessors( qw/ debug -port +store_path + sock state queue +store / ); -use IO::Socket::INET; +use HTTP::Daemon; use Data::Dump qw/dump/; +use Carp qw/confess cluck croak/; +use File::Slurp; + use CWMP::Request; use CWMP::Response; -use Carp qw/confess cluck/; +use CWMP::Store; =head1 NAME -CWMP::Server - implement logic of CWMP protocol +CWMP::Session - implement logic of CWMP protocol =head1 METHODS =head2 new - my $server = CWMP::Server->new({ port => 3333 }); + my $server = CWMP::Session->new({ + sock => $io_socket_object, + store_path => 'state.db', + queue => [ qw/GetRPCMethods GetParameterNames/ ], + debug => 1, + }); -=head2 run +=cut - $server->run(); +sub new { + my $class = shift; + my $self = $class->SUPER::new( @_ ); -=cut + confess "need sock" unless $self->sock; -sub run { - my $self = shift; + $self->debug( 0 ) unless $self->debug; - my $listen = IO::Socket::INET->new( - Listen => 5, -# LocalAddr => 'localhost', - LocalPort => $self->port, - Proto => 'tcp', - Blocking => 1, - ReuseAddr => 1, - ); - - warn "ACS waiting for request on port ", $self->port, " queue ( ", join(",",@{$self->queue}), " )\n"; - - while ( my $sock = $listen->accept ) { - $sock->autoflush(1); - - warn "connection from ", $sock->peerhost, "\n"; - - $self->sock( $sock ); # FIXME this will not work for multiple clients - while ( $self->process_request ) { - warn "...another one bites a dust...\n"; - } + warn "created ", __PACKAGE__, "(", dump( @_ ), ") for ", $self->sock->peerhost, "\n" if $self->debug; - warn "...returning to accepting new connections\n"; - } + $self->store( CWMP::Store->new({ + debug => $self->debug, + path => $self->store_path, + }) ); + + croak "can't open ", $self->store_path, ": $!" unless $self->store; + + return $self; } =head2 process_request @@ -69,88 +67,51 @@ facilitate brain-dead concept of adding state to stateless protocol like HTTP. +If used with debugging level of 3 or more, it will also create dumps of +requests named C<< nr.dump >> where C is number from 0 to total number +of requests in single session. + =cut +my $dump_nr = 0; + 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 'IO::Socket::INET' ); +# die "not IO::Socket::INET but ", ref( $sock ) unless ( ref($sock) eq 'Net::Server::Proto::TCP' ); if ( ! $sock->connected ) { - warn "SOCKET NOT CONNECTED"; + warn "SOCKET NOT CONNECTED\n"; return 0; } - $sock->autoflush( 1 ); - $sock->blocking( 1 ); + bless $sock, 'HTTP::Daemon::ClientConn'; - ### read the first line of response - my $line = $sock->getline; - return $self->error(400, "No Data") unless ( defined $line ); - - $line =~ s/[\r\n]+$//; - if ($line !~ /^ (\w+) \ + (\S+) \ + (HTTP\/1.\d) $ /x) { - warn "ERROR: $line\n"; - return $self->error(400, "Bad request"); - } - my ($method, $req, $protocol) = ($1, $2, $3); - warn "<<<< ", $sock->peerhost, " - - [" . localtime() . "] \"$method $req $protocol\"\n"; + # why do I have to do this? + # solution from http://use.perl.org/~Matts/journal/12896 + ${*$sock}{'httpd_daemon'} = HTTP::Daemon->new; - ### read in other headers - $self->read_headers || return $self->error(400, "Strange headers"); + my $r = $sock->get_request || confess "can't get_request"; - ### do we support the type -# if ($method !~ /GET|POST|HEAD/) { - if ($method !~ /POST/) { - return $self->error(400, "Unsupported Method"); - } - - my $chunk; - my $transfer_encoding = $self->header('Transfer-Encoding'); - - if ( $transfer_encoding && $transfer_encoding =~ qr/^chunked/i ) { - - my $len = 0; - - do { - - warn "get chunk len\n" if $self->debug; - - my $hex; - do { - $hex = $sock->getline; - $hex =~ s/[\n\r]+$//; - } until ( $hex ne '' ); + my $chunk = $r->content; - die "chunk size not valid hex: $hex" unless ( $hex =~ m/^[0-9a-f]+$/i); - $len = hex( $hex ); - - warn "getting chunk of $len bytes\n" if $self->debug; - - $sock->read( my $buff, $len ); - $chunk .= $buff; - - warn "--- $len bytes: --=>||$buff||<=--\n"; + my $size = length( $chunk ); - } while ( $len > 0 ); - my $sep = $sock->getline; - die "expected separator, not ", dump( $sep ) if ( $sep !~ m/^[\n\r]+$/ ); + warn "<<<< ", $sock->peerhost, " [" . localtime() . "] ", $r->method, " ", $r->uri, " $size bytes\n"; - } else { - die "right now, we support only Transfer-Encoding: chunked"; + if ( $self->debug > 2 ) { + my $file = $dump_nr++ . '.dump'; + write_file( $file, $r->as_string ); + warn "### request dump: $file\n"; } - my $size = length( $chunk ); - - warn "<<< " . $sock->peerhost . " [" . localtime() . "] request $size bytes\n"; - my $state; if ( $size > 0 ) { - die "no SOAPAction header in ",dump($chunk) unless defined ( $self->header('SOAPAction') ); + die "no SOAPAction header in ",dump($chunk) unless defined ( $r->header('SOAPAction') ); if ( $chunk ) { @@ -158,17 +119,18 @@ $state = CWMP::Request->parse( $chunk ); - warn "acquired state = ", dump( $state ), "\n"; + warn "## acquired state = ", dump( $state ), "\n"; $self->state( $state ); + $self->store->update_state( ID => $state->{ID}, $state ); } else { - warn "empty request\n"; + warn "## empty request\n"; } } else { $state = $self->state; - warn "last request state = ", dump( $state ), "\n"; + warn "last request state = ", dump( $state ), "\n" if $self->debug > 1; } @@ -177,7 +139,7 @@ 'Content-Type: text/xml; charset="utf-8"', 'Server: AcmeCWMP/42', 'SOAPServer: AcmeCWMP/42' - )); + )."\r\n"); $sock->send( "Set-Cookie: ID=" . $state->{ID} . "; path=/\r\n" ) if ( $state->{ID} ); @@ -199,8 +161,11 @@ $sock->send( "Content-Length: " . length( $xml ) . "\r\n\r\n" ); $sock->send( $xml ) or die "can't send response"; - warn "### request over"; + warn ">>>> " . $sock->peerhost . " [" . localtime() . "] sent ", length( $xml )," bytes\n"; + warn "### request over\n" if $self->debug; + + return 1; # next request }; =head2 dispatch @@ -218,53 +183,14 @@ if ( $response->can( $dispatch ) ) { warn ">>> dispatching to $dispatch\n"; - my $xml = $response->$dispatch( $self->state, @_ ) . "\r\n"; - warn "## response payload: ",length($xml)," bytes\n$xml\n"; + my $xml = $response->$dispatch( $self->state, @_ ); + warn "## response payload: ",length($xml)," bytes\n$xml\n" if $self->debug; return $xml; } else { confess "can't dispatch to $dispatch"; } }; -=head2 read_headers - -parse headers from request - -=cut - -sub read_headers { - my $self = shift; - - $self->{headers} = {}; - - while (defined($_ = $self->sock->getline)) { - s/[\r\n]+$//; - last unless length $_; - warn "-- $_\n"; - return 0 if ! /^ ([\w\-]+) :[\ \t]* (.*) $/x; - $self->{headers}->{$1} = $2; - } - - return 1; -} - -=head2 header - -Getter for specific header - - $self->header('Cookies'); - -=cut - -sub header { - my $self = shift; - my $header = shift || die "no header?"; - if ( defined( $self->{headers}->{$header} )) { - return $self->{headers}->{$header}; - } else { - return; - } -} =head2 error