use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors( qw/
port
-store
-default_queue
+session
background
debug
+create_dump
server
/ );
use CWMP::Session;
+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
my $server = CWMP::Server->new({
port => 3333,
- store => {
- module => 'DBMDeep',
- path => 'var/',
- },
- default_queue => [ qw/GetRPCMethods GetParameterNames/ ],
+ session => { ... },
background => 1,
debug => 1
});
port to listen on
-=item store
+=item session
hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
is used. Other parametars are optional.
-=item default_queue
-
-commands which will be issued to every CPE on connect
-
=back
=cut
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,
- default_queue => $self->default_queue,
- store => $self->store,
- debug => $self->debug,
- background => $self->background,
- })
- );
-
return $self;
}
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/ store 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;
+
+ 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;
+ }
+
+ warn "<<<< $ip START\n$request\n";
+
+ return $sock->connected unless $headers;
+
+ warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
- my $prop = $self->{server};
- confess "no server in ", ref( $self ) unless $prop;
- my $sock = $prop->{client};
- confess "no sock in ", ref( $self ) unless $sock;
+ 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 "default CPE queue ( " . join(",",@{$prop->{default_queue}}) . " )\n" if defined($prop->{default_queue});
+ warn "$body\n<<<< $ip END\n";
- eval {
- my $session = CWMP::Session->new({
- sock => $sock,
- queue => $prop->{default_queue},
- store => $prop->{store},
- debug => $prop->{debug},
- }) || confess "can't create session";
- while ( $session->process_request ) {
- warn "...another one bites the dust...\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 );
- if ($@) {
- warn $@;
+ 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 "...returning to accepting new connections\n";
+ warn ">>>> $ip START\n$response\n>>>> $ip END\n";
+ print $sock $response;
+
+ return $sock->connected;
}
+
1;
projects / perl-cwmp.git / blobdiff