--- google/lib/CWMP/Server.pm 2007/06/19 18:11:37 41 +++ google/lib/CWMP/Server.pm 2007/06/19 21:29:04 50 @@ -9,6 +9,8 @@ debug port sock +state +queue / ); use IO::Socket::INET; @@ -53,35 +55,51 @@ warn "connection from ", $sock->peerhost, "\n"; $self->sock( $sock ); # FIXME this will not work for multiple clients - $self->process_request( $sock ); + while ( $self->process_request ) { + warn "...another one bites a dust...\n"; + } - warn "...another one bites a dust...\n"; - sleep 1; + warn "...returning to accepting new connections\n"; } } +=head2 process_request + +One request from client/response from server cycle. Call multiple times to +facilitate brain-dead concept of adding state to stateless protocol like +HTTP. + +=cut + sub process_request { my $self = shift; - my $sock = shift || die "no sock?"; + my $sock = $self->sock || die "no sock?"; die "not IO::Socket::INET but ", ref( $sock ) unless ( ref($sock) eq 'IO::Socket::INET' ); + if ( ! $sock->connected ) { + warn "SOCKET NOT CONNECTED"; + return 0; + } + $sock->autoflush( 1 ); $sock->blocking( 1 ); ### read the first line of response - my $line = $sock->getline; # || $self->error(400, "No Data"); + 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 "<<<< ",join(" ", time, $method, $req)."\n"; + warn "<<<< ", $sock->peerhost, " - - [" . localtime() . "] \"$method $req $protocol\"\n"; ### read in other headers - $self->read_headers($sock) || return $self->error(400, "Strange headers"); + $self->read_headers || return $self->error(400, "Strange headers"); ### do we support the type # if ($method !~ /GET|POST|HEAD/) { @@ -117,72 +135,109 @@ warn "--- $len bytes: --=>||$buff||<=--\n"; } while ( $len > 0 ); + my $sep = $sock->getline; + die "expected separator, not ", dump( $sep ) if ( $sep !~ m/^[\n\r]+$/ ); } else { die "right now, we support only Transfer-Encoding: chunked"; } - warn "handler got ", length($chunk), " bytes\n" if $self->debug; + my $size = length( $chunk ); - warn "<<< " . localtime() . " " . $sock->peerhost . "\n"; - - die "not SOAP request" unless defined ( $self->header('SOAPAction') ); + warn "<<< " . $sock->peerhost . " [" . localtime() . "] request $size bytes\n"; my $state; - if ( $chunk ) { - warn "## request chunk: ",length($chunk)," bytes\n$chunk\n" if $self->debug; + if ( $size > 0 ) { - $state = CWMP::Request->parse( $chunk ); + die "no SOAPAction header in ",dump($chunk) unless defined ( $self->header('SOAPAction') ); + + + if ( $chunk ) { + warn "## request chunk: ",length($chunk)," bytes\n$chunk\n" if $self->debug; + + $state = CWMP::Request->parse( $chunk ); + + warn "acquired state = ", dump( $state ), "\n"; + + $self->state( $state ); + + } else { + warn "empty request\n"; + } - warn "acquired state = ", dump( $state ), "\n"; - } else { - warn "empty request\n"; + $state = $self->state; + warn "last request state = ", dump( $state ), "\n"; } - my $response = CWMP::Response->new({ debug => $self->debug }); + $sock->send(join("\r\n", + 'HTTP/1.1 200 OK', + 'Content-Type: text/xml; charset="utf-8"', + 'Server: AcmeCWMP/42', + 'SOAPServer: AcmeCWMP/42' + )); - $sock->print( - $self->status(200), - $self->content_type('text/xml; charset="utf-8"'), - "Server: AcmeCWMP/42\r\n", - "SOAPServer: AcmeCWMP/42\r\n" - ); - - $sock->print( "Set-Cookie: ID=" , $state->{ID}, "; path=/\r\n" ) if ( $state->{ID} ); + $sock->send( "Set-Cookie: ID=" . $state->{ID} . "; path=/\r\n" ) if ( $state->{ID} ); my $xml = ''; if ( my $dispatch = $state->{_dispatch} ) { - if ( $response->can( $dispatch ) ) { - warn ">>> dispatching to $dispatch\n"; - $xml = $response->$dispatch( $state ) . "\r\n"; - warn "## response payload: ",length($xml)," bytes\n$xml\n"; - } else { - confess "can't dispatch to $dispatch"; - } + $xml = $self->dispatch( $dispatch ); + } elsif ( $dispatch = shift @{ $self->queue } ) { + $xml = $self->dispatch( $dispatch ); + } elsif ( $size == 0 ) { + warn ">>> closing connection\n"; + return 0; } else { warn ">>> empty response\n"; + $state->{NoMoreRequests} = 1; + $xml = $self->dispatch( 'xml', sub {} ); } - $sock->print( "Content-length: ", length( $xml ), "\r\n\r\n" ); - $sock->print( $xml ) or die "can't send response"; + $sock->send( "Content-Length: " . length( $xml ) . "\r\n\r\n" ); + $sock->send( $xml ) or die "can't send response"; warn "### request over"; }; +=head2 dispatch + + $xml = $self->dispatch('Inform', $response_arguments ); + +=cut + +sub dispatch { + my $self = shift; + + my $dispatch = shift || die "no dispatch?"; + + my $response = CWMP::Response->new({ debug => $self->debug }); + + 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"; + return $xml; + } else { + confess "can't dispatch to $dispatch"; + } +}; + +=head2 read_headers + +parse headers from request + +=cut sub read_headers { my $self = shift; - my $sock = shift || die "no sock?"; - $self->{headers} = {}; - while (defined($_ = $sock->getline)) { + while (defined($_ = $self->sock->getline)) { s/[\r\n]+$//; last unless length $_; warn "-- $_\n"; @@ -193,6 +248,14 @@ return 1; } +=head2 header + +Getter for specific header + + $self->header('Cookies'); + +=cut + sub header { my $self = shift; my $header = shift || die "no header?"; @@ -203,31 +266,18 @@ } } -sub content_type { - my ($self, $type) = @_; - $self->http_header; - return "Content-type: $type\r\n"; -} +=head2 error -sub error{ - my ($self, $number, $msg) = @_; - $self->sock->print( $self->status($number, $msg), "\r\n" ); - warn "Error - $number - $msg\n"; -} + return $self->error( 501, 'System error' ); -sub status { - my ($self, $number, $msg) = @_; - $msg = '' if ! defined $msg; - return if $self->http_header($number); - return "Status $number: $msg\r\n"; -} +=cut -sub http_header { - my $self = shift; - my $number = shift || 200; - return if ! delete $self->{needs_header}; - $self->sock->Print("HTTP/1.0 $number\r\n"); - return 1; +sub error { + my ($self, $number, $msg) = @_; + $msg ||= 'ERROR'; + $self->sock->send( "HTTP/1.1 $number $msg\r\n" ); + warn "Error - $number - $msg\n"; + return 0; # close connection } 1;